1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2017 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
= integer_minus_one_node
;
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
, 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
, boolean_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). */
455 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
456 gfc_mark_ss_chain_used (ss
, 1);
458 /* Convert the arguments, checking for dependencies. */
459 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
462 /* For operator assignment, do dependency checking. */
463 if (dependency_check
)
464 check_variable
= ELEM_CHECK_VARIABLE
;
466 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
468 gfc_init_se (&depse
, NULL
);
469 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
470 code
->ext
.actual
, check_variable
);
472 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
473 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
475 /* Generate the loop body. */
476 gfc_start_scalarized_body (&loop
, &body
);
477 gfc_init_block (&block
);
481 /* Form the mask expression according to the mask. */
483 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
485 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
486 TREE_TYPE (maskexpr
), maskexpr
);
489 /* Add the subroutine call to the block. */
490 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
491 code
->ext
.actual
, code
->expr1
,
496 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
497 build_empty_stmt (input_location
));
498 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
499 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
500 gfc_array_index_type
,
501 count1
, gfc_index_one_node
);
502 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
505 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
507 gfc_add_block_to_block (&block
, &loopse
.pre
);
508 gfc_add_block_to_block (&block
, &loopse
.post
);
510 /* Finish up the loop block and the loop. */
511 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
512 gfc_trans_scalarizing_loops (&loop
, &body
);
513 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
514 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
515 gfc_add_block_to_block (&se
.pre
, &se
.post
);
516 gfc_cleanup_loop (&loop
);
519 return gfc_finish_block (&se
.pre
);
523 /* Translate the RETURN statement. */
526 gfc_trans_return (gfc_code
* code
)
534 /* If code->expr is not NULL, this return statement must appear
535 in a subroutine and current_fake_result_decl has already
538 result
= gfc_get_fake_result_decl (NULL
, 0);
542 "An alternate return at %L without a * dummy argument",
543 &code
->expr1
->where
);
544 return gfc_generate_return ();
547 /* Start a new block for this statement. */
548 gfc_init_se (&se
, NULL
);
549 gfc_start_block (&se
.pre
);
551 gfc_conv_expr (&se
, code
->expr1
);
553 /* Note that the actually returned expression is a simple value and
554 does not depend on any pointers or such; thus we can clean-up with
555 se.post before returning. */
556 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
557 result
, fold_convert (TREE_TYPE (result
),
559 gfc_add_expr_to_block (&se
.pre
, tmp
);
560 gfc_add_block_to_block (&se
.pre
, &se
.post
);
562 tmp
= gfc_generate_return ();
563 gfc_add_expr_to_block (&se
.pre
, tmp
);
564 return gfc_finish_block (&se
.pre
);
567 return gfc_generate_return ();
571 /* Translate the PAUSE statement. We have to translate this statement
572 to a runtime library call. */
575 gfc_trans_pause (gfc_code
* code
)
577 tree gfc_int4_type_node
= gfc_get_int_type (4);
581 /* Start a new block for this statement. */
582 gfc_init_se (&se
, NULL
);
583 gfc_start_block (&se
.pre
);
586 if (code
->expr1
== NULL
)
588 tmp
= build_int_cst (gfc_int4_type_node
, 0);
589 tmp
= build_call_expr_loc (input_location
,
590 gfor_fndecl_pause_string
, 2,
591 build_int_cst (pchar_type_node
, 0), tmp
);
593 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
595 gfc_conv_expr (&se
, code
->expr1
);
596 tmp
= build_call_expr_loc (input_location
,
597 gfor_fndecl_pause_numeric
, 1,
598 fold_convert (gfc_int4_type_node
, se
.expr
));
602 gfc_conv_expr_reference (&se
, code
->expr1
);
603 tmp
= build_call_expr_loc (input_location
,
604 gfor_fndecl_pause_string
, 2,
605 se
.expr
, se
.string_length
);
608 gfc_add_expr_to_block (&se
.pre
, tmp
);
610 gfc_add_block_to_block (&se
.pre
, &se
.post
);
612 return gfc_finish_block (&se
.pre
);
616 /* Translate the STOP statement. We have to translate this statement
617 to a runtime library call. */
620 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
622 tree gfc_int4_type_node
= gfc_get_int_type (4);
626 /* Start a new block for this statement. */
627 gfc_init_se (&se
, NULL
);
628 gfc_start_block (&se
.pre
);
630 if (code
->expr1
== NULL
)
632 tmp
= build_int_cst (gfc_int4_type_node
, 0);
633 tmp
= build_call_expr_loc (input_location
,
635 ? (flag_coarray
== GFC_FCOARRAY_LIB
636 ? gfor_fndecl_caf_error_stop_str
637 : gfor_fndecl_error_stop_string
)
638 : (flag_coarray
== GFC_FCOARRAY_LIB
639 ? gfor_fndecl_caf_stop_str
640 : gfor_fndecl_stop_string
),
641 2, build_int_cst (pchar_type_node
, 0), tmp
);
643 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
645 gfc_conv_expr (&se
, code
->expr1
);
646 tmp
= build_call_expr_loc (input_location
,
648 ? (flag_coarray
== GFC_FCOARRAY_LIB
649 ? gfor_fndecl_caf_error_stop
650 : gfor_fndecl_error_stop_numeric
)
651 : (flag_coarray
== GFC_FCOARRAY_LIB
652 ? gfor_fndecl_caf_stop_numeric
653 : gfor_fndecl_stop_numeric
), 1,
654 fold_convert (gfc_int4_type_node
, se
.expr
));
658 gfc_conv_expr_reference (&se
, code
->expr1
);
659 tmp
= build_call_expr_loc (input_location
,
661 ? (flag_coarray
== GFC_FCOARRAY_LIB
662 ? gfor_fndecl_caf_error_stop_str
663 : gfor_fndecl_error_stop_string
)
664 : (flag_coarray
== GFC_FCOARRAY_LIB
665 ? gfor_fndecl_caf_stop_str
666 : gfor_fndecl_stop_string
),
667 2, se
.expr
, se
.string_length
);
670 gfc_add_expr_to_block (&se
.pre
, tmp
);
672 gfc_add_block_to_block (&se
.pre
, &se
.post
);
674 return gfc_finish_block (&se
.pre
);
679 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
682 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
683 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
685 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
686 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
687 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
692 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
693 gfc_init_se (&argse
, NULL
);
694 gfc_conv_expr_val (&argse
, code
->expr2
);
697 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
698 stat
= null_pointer_node
;
702 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
703 gfc_init_se (&argse
, NULL
);
704 gfc_conv_expr_val (&argse
, code
->expr4
);
705 lock_acquired
= argse
.expr
;
707 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
708 lock_acquired
= null_pointer_node
;
710 gfc_start_block (&se
.pre
);
711 if (flag_coarray
== GFC_FCOARRAY_LIB
)
713 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
714 tree index
= size_zero_node
;
715 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
717 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
718 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
719 != INTMOD_ISO_FORTRAN_ENV
720 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
721 != ISOFORTRAN_LOCK_TYPE
)
723 gfc_error ("Sorry, the lock component of derived type at %L is not "
724 "yet supported", &code
->expr1
->where
);
728 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
731 if (gfc_is_coindexed (code
->expr1
))
732 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
734 image_index
= integer_zero_node
;
736 /* For arrays, obtain the array index. */
737 if (gfc_expr_attr (code
->expr1
).dimension
)
739 tree desc
, tmp
, extent
, lbound
, ubound
;
740 gfc_array_ref
*ar
, ar2
;
743 /* TODO: Extend this, once DT components are supported. */
744 ar
= &code
->expr1
->ref
->u
.ar
;
746 memset (ar
, '\0', sizeof (*ar
));
750 gfc_init_se (&argse
, NULL
);
751 argse
.descriptor_only
= 1;
752 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
753 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
757 extent
= integer_one_node
;
758 for (i
= 0; i
< ar
->dimen
; i
++)
760 gfc_init_se (&argse
, NULL
);
761 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
762 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
763 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
764 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
765 integer_type_node
, argse
.expr
,
766 fold_convert(integer_type_node
, lbound
));
767 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
768 integer_type_node
, extent
, tmp
);
769 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
770 integer_type_node
, index
, tmp
);
771 if (i
< ar
->dimen
- 1)
773 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
774 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
775 tmp
= fold_convert (integer_type_node
, tmp
);
776 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
777 integer_type_node
, extent
, tmp
);
785 gfc_init_se (&argse
, NULL
);
786 argse
.want_pointer
= 1;
787 gfc_conv_expr (&argse
, code
->expr3
);
788 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
790 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
794 errmsg
= null_pointer_node
;
795 errmsg_len
= integer_zero_node
;
798 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
801 stat
= gfc_create_var (integer_type_node
, "stat");
804 if (lock_acquired
!= null_pointer_node
805 && TREE_TYPE (lock_acquired
) != integer_type_node
)
807 lock_acquired2
= lock_acquired
;
808 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
812 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
813 token
, index
, image_index
,
814 lock_acquired
!= null_pointer_node
815 ? gfc_build_addr_expr (NULL
, lock_acquired
)
817 stat
!= null_pointer_node
818 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
821 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
822 token
, index
, image_index
,
823 stat
!= null_pointer_node
824 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
826 gfc_add_expr_to_block (&se
.pre
, tmp
);
828 /* It guarantees memory consistency within the same segment */
829 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
830 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
831 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
832 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
833 ASM_VOLATILE_P (tmp
) = 1;
835 gfc_add_expr_to_block (&se
.pre
, tmp
);
837 if (stat2
!= NULL_TREE
)
838 gfc_add_modify (&se
.pre
, stat2
,
839 fold_convert (TREE_TYPE (stat2
), stat
));
841 if (lock_acquired2
!= NULL_TREE
)
842 gfc_add_modify (&se
.pre
, lock_acquired2
,
843 fold_convert (TREE_TYPE (lock_acquired2
),
846 return gfc_finish_block (&se
.pre
);
849 if (stat
!= NULL_TREE
)
850 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
852 if (lock_acquired
!= NULL_TREE
)
853 gfc_add_modify (&se
.pre
, lock_acquired
,
854 fold_convert (TREE_TYPE (lock_acquired
),
857 return gfc_finish_block (&se
.pre
);
861 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
864 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
865 tree until_count
= NULL_TREE
;
869 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
870 gfc_init_se (&argse
, NULL
);
871 gfc_conv_expr_val (&argse
, code
->expr2
);
874 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
875 stat
= null_pointer_node
;
879 gfc_init_se (&argse
, NULL
);
880 gfc_conv_expr_val (&argse
, code
->expr4
);
881 until_count
= fold_convert (integer_type_node
, argse
.expr
);
884 until_count
= integer_one_node
;
886 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
888 gfc_start_block (&se
.pre
);
889 gfc_init_se (&argse
, NULL
);
890 gfc_conv_expr_val (&argse
, code
->expr1
);
892 if (op
== EXEC_EVENT_POST
)
893 gfc_add_modify (&se
.pre
, argse
.expr
,
894 fold_build2_loc (input_location
, PLUS_EXPR
,
895 TREE_TYPE (argse
.expr
), argse
.expr
,
896 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
898 gfc_add_modify (&se
.pre
, argse
.expr
,
899 fold_build2_loc (input_location
, MINUS_EXPR
,
900 TREE_TYPE (argse
.expr
), argse
.expr
,
901 fold_convert (TREE_TYPE (argse
.expr
),
903 if (stat
!= NULL_TREE
)
904 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
906 return gfc_finish_block (&se
.pre
);
909 gfc_start_block (&se
.pre
);
910 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
911 tree index
= size_zero_node
;
912 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
914 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
915 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
916 != INTMOD_ISO_FORTRAN_ENV
917 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
918 != ISOFORTRAN_EVENT_TYPE
)
920 gfc_error ("Sorry, the event component of derived type at %L is not "
921 "yet supported", &code
->expr1
->where
);
925 gfc_init_se (&argse
, NULL
);
926 gfc_get_caf_token_offset (&argse
, &token
, NULL
, caf_decl
, NULL_TREE
,
928 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
930 if (gfc_is_coindexed (code
->expr1
))
931 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
933 image_index
= integer_zero_node
;
935 /* For arrays, obtain the array index. */
936 if (gfc_expr_attr (code
->expr1
).dimension
)
938 tree desc
, tmp
, extent
, lbound
, ubound
;
939 gfc_array_ref
*ar
, ar2
;
942 /* TODO: Extend this, once DT components are supported. */
943 ar
= &code
->expr1
->ref
->u
.ar
;
945 memset (ar
, '\0', sizeof (*ar
));
949 gfc_init_se (&argse
, NULL
);
950 argse
.descriptor_only
= 1;
951 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
952 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
956 extent
= integer_one_node
;
957 for (i
= 0; i
< ar
->dimen
; i
++)
959 gfc_init_se (&argse
, NULL
);
960 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
961 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
962 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
963 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
964 integer_type_node
, argse
.expr
,
965 fold_convert(integer_type_node
, lbound
));
966 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
967 integer_type_node
, extent
, tmp
);
968 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
969 integer_type_node
, index
, tmp
);
970 if (i
< ar
->dimen
- 1)
972 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
973 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
974 tmp
= fold_convert (integer_type_node
, tmp
);
975 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
976 integer_type_node
, extent
, tmp
);
984 gfc_init_se (&argse
, NULL
);
985 argse
.want_pointer
= 1;
986 gfc_conv_expr (&argse
, code
->expr3
);
987 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
989 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
993 errmsg
= null_pointer_node
;
994 errmsg_len
= integer_zero_node
;
997 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
1000 stat
= gfc_create_var (integer_type_node
, "stat");
1003 if (op
== EXEC_EVENT_POST
)
1004 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1005 token
, index
, image_index
,
1006 stat
!= null_pointer_node
1007 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1008 errmsg
, errmsg_len
);
1010 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1011 token
, index
, until_count
,
1012 stat
!= null_pointer_node
1013 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1014 errmsg
, errmsg_len
);
1015 gfc_add_expr_to_block (&se
.pre
, tmp
);
1017 /* It guarantees memory consistency within the same segment */
1018 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1019 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1020 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1021 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1022 ASM_VOLATILE_P (tmp
) = 1;
1023 gfc_add_expr_to_block (&se
.pre
, tmp
);
1025 if (stat2
!= NULL_TREE
)
1026 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1028 return gfc_finish_block (&se
.pre
);
1032 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1036 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1037 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1039 /* Short cut: For single images without bound checking or without STAT=,
1040 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1041 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1042 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1045 gfc_init_se (&se
, NULL
);
1046 gfc_start_block (&se
.pre
);
1048 if (code
->expr1
&& code
->expr1
->rank
== 0)
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr_val (&argse
, code
->expr1
);
1052 images
= argse
.expr
;
1057 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1058 gfc_init_se (&argse
, NULL
);
1059 gfc_conv_expr_val (&argse
, code
->expr2
);
1063 stat
= null_pointer_node
;
1065 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1067 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
1068 gfc_init_se (&argse
, NULL
);
1069 argse
.want_pointer
= 1;
1070 gfc_conv_expr (&argse
, code
->expr3
);
1071 gfc_conv_string_parameter (&argse
);
1072 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1073 errmsglen
= argse
.string_length
;
1075 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1077 errmsg
= null_pointer_node
;
1078 errmsglen
= build_int_cst (integer_type_node
, 0);
1081 /* Check SYNC IMAGES(imageset) for valid image index.
1082 FIXME: Add a check for image-set arrays. */
1083 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1084 && code
->expr1
->rank
== 0)
1087 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1088 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1089 images
, build_int_cst (TREE_TYPE (images
), 1));
1093 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1094 2, integer_zero_node
,
1095 build_int_cst (integer_type_node
, -1));
1096 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1098 cond2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1100 build_int_cst (TREE_TYPE (images
), 1));
1101 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1102 boolean_type_node
, cond
, cond2
);
1104 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1105 &code
->expr1
->where
, "Invalid image number "
1106 "%d in SYNC IMAGES",
1107 fold_convert (integer_type_node
, images
));
1110 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1111 image control statements SYNC IMAGES and SYNC ALL. */
1112 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1114 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1115 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1116 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1117 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1118 ASM_VOLATILE_P (tmp
) = 1;
1119 gfc_add_expr_to_block (&se
.pre
, tmp
);
1122 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1124 /* Set STAT to zero. */
1126 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1128 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1130 /* SYNC ALL => stat == null_pointer_node
1131 SYNC ALL(stat=s) => stat has an integer type
1133 If "stat" has the wrong integer type, use a temp variable of
1134 the right type and later cast the result back into "stat". */
1135 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1137 if (TREE_TYPE (stat
) == integer_type_node
)
1138 stat
= gfc_build_addr_expr (NULL
, stat
);
1140 if(type
== EXEC_SYNC_MEMORY
)
1141 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1142 3, stat
, errmsg
, errmsglen
);
1144 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1145 3, stat
, errmsg
, errmsglen
);
1147 gfc_add_expr_to_block (&se
.pre
, tmp
);
1151 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1153 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1154 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1156 gfc_add_expr_to_block (&se
.pre
, tmp
);
1158 gfc_add_modify (&se
.pre
, stat
,
1159 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1166 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1170 len
= build_int_cst (integer_type_node
, -1);
1171 images
= null_pointer_node
;
1173 else if (code
->expr1
->rank
== 0)
1175 len
= build_int_cst (integer_type_node
, 1);
1176 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1181 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1182 gfc_fatal_error ("Sorry, only support for integer kind %d "
1183 "implemented for image-set at %L",
1184 gfc_c_int_kind
, &code
->expr1
->where
);
1186 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1189 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1190 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1191 tmp
= gfc_get_element_type (tmp
);
1193 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1194 TREE_TYPE (len
), len
,
1195 fold_convert (TREE_TYPE (len
),
1196 TYPE_SIZE_UNIT (tmp
)));
1197 len
= fold_convert (integer_type_node
, len
);
1200 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1201 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1203 If "stat" has the wrong integer type, use a temp variable of
1204 the right type and later cast the result back into "stat". */
1205 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1207 if (TREE_TYPE (stat
) == integer_type_node
)
1208 stat
= gfc_build_addr_expr (NULL
, stat
);
1210 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1211 5, fold_convert (integer_type_node
, len
),
1212 images
, stat
, errmsg
, errmsglen
);
1213 gfc_add_expr_to_block (&se
.pre
, tmp
);
1217 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1219 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1220 5, fold_convert (integer_type_node
, len
),
1221 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1223 gfc_add_expr_to_block (&se
.pre
, tmp
);
1225 gfc_add_modify (&se
.pre
, stat
,
1226 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1230 return gfc_finish_block (&se
.pre
);
1234 /* Generate GENERIC for the IF construct. This function also deals with
1235 the simple IF statement, because the front end translates the IF
1236 statement into an IF construct.
1268 where COND_S is the simplified version of the predicate. PRE_COND_S
1269 are the pre side-effects produced by the translation of the
1271 We need to build the chain recursively otherwise we run into
1272 problems with folding incomplete statements. */
1275 gfc_trans_if_1 (gfc_code
* code
)
1278 tree stmt
, elsestmt
;
1282 /* Check for an unconditional ELSE clause. */
1284 return gfc_trans_code (code
->next
);
1286 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1287 gfc_init_se (&if_se
, NULL
);
1288 gfc_start_block (&if_se
.pre
);
1290 /* Calculate the IF condition expression. */
1291 if (code
->expr1
->where
.lb
)
1293 gfc_save_backend_locus (&saved_loc
);
1294 gfc_set_backend_locus (&code
->expr1
->where
);
1297 gfc_conv_expr_val (&if_se
, code
->expr1
);
1299 if (code
->expr1
->where
.lb
)
1300 gfc_restore_backend_locus (&saved_loc
);
1302 /* Translate the THEN clause. */
1303 stmt
= gfc_trans_code (code
->next
);
1305 /* Translate the ELSE clause. */
1307 elsestmt
= gfc_trans_if_1 (code
->block
);
1309 elsestmt
= build_empty_stmt (input_location
);
1311 /* Build the condition expression and add it to the condition block. */
1312 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1313 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1316 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1318 /* Finish off this statement. */
1319 return gfc_finish_block (&if_se
.pre
);
1323 gfc_trans_if (gfc_code
* code
)
1328 /* Create exit label so it is available for trans'ing the body code. */
1329 exit_label
= gfc_build_label_decl (NULL_TREE
);
1330 code
->exit_label
= exit_label
;
1332 /* Translate the actual code in code->block. */
1333 gfc_init_block (&body
);
1334 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1336 /* Add exit label. */
1337 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1339 return gfc_finish_block (&body
);
1343 /* Translate an arithmetic IF expression.
1345 IF (cond) label1, label2, label3 translates to
1357 An optimized version can be generated in case of equal labels.
1358 E.g., if label1 is equal to label2, we can translate it to
1367 gfc_trans_arithmetic_if (gfc_code
* code
)
1375 /* Start a new block. */
1376 gfc_init_se (&se
, NULL
);
1377 gfc_start_block (&se
.pre
);
1379 /* Pre-evaluate COND. */
1380 gfc_conv_expr_val (&se
, code
->expr1
);
1381 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1383 /* Build something to compare with. */
1384 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1386 if (code
->label1
->value
!= code
->label2
->value
)
1388 /* If (cond < 0) take branch1 else take branch2.
1389 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1390 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1391 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1393 if (code
->label1
->value
!= code
->label3
->value
)
1394 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1397 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1400 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1401 tmp
, branch1
, branch2
);
1404 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1406 if (code
->label1
->value
!= code
->label3
->value
1407 && code
->label2
->value
!= code
->label3
->value
)
1409 /* if (cond <= 0) take branch1 else take branch2. */
1410 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1411 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1413 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1414 tmp
, branch1
, branch2
);
1417 /* Append the COND_EXPR to the evaluation of COND, and return. */
1418 gfc_add_expr_to_block (&se
.pre
, branch1
);
1419 return gfc_finish_block (&se
.pre
);
1423 /* Translate a CRITICAL block. */
1425 gfc_trans_critical (gfc_code
*code
)
1428 tree tmp
, token
= NULL_TREE
;
1430 gfc_start_block (&block
);
1432 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1434 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1435 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1436 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1437 token
, integer_zero_node
, integer_one_node
,
1438 null_pointer_node
, null_pointer_node
,
1439 null_pointer_node
, integer_zero_node
);
1440 gfc_add_expr_to_block (&block
, tmp
);
1442 /* It guarantees memory consistency within the same segment */
1443 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1444 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1445 gfc_build_string_const (1, ""),
1446 NULL_TREE
, NULL_TREE
,
1447 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1449 ASM_VOLATILE_P (tmp
) = 1;
1451 gfc_add_expr_to_block (&block
, tmp
);
1454 tmp
= gfc_trans_code (code
->block
->next
);
1455 gfc_add_expr_to_block (&block
, tmp
);
1457 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1459 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1460 token
, integer_zero_node
, integer_one_node
,
1461 null_pointer_node
, null_pointer_node
,
1463 gfc_add_expr_to_block (&block
, tmp
);
1465 /* It guarantees memory consistency within the same segment */
1466 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1467 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1468 gfc_build_string_const (1, ""),
1469 NULL_TREE
, NULL_TREE
,
1470 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1472 ASM_VOLATILE_P (tmp
) = 1;
1474 gfc_add_expr_to_block (&block
, tmp
);
1477 return gfc_finish_block (&block
);
1481 /* Return true, when the class has a _len component. */
1484 class_has_len_component (gfc_symbol
*sym
)
1486 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1489 if (strcmp (comp
->name
, "_len") == 0)
1497 /* Do proper initialization for ASSOCIATE names. */
1500 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1511 bool need_len_assign
;
1513 gcc_assert (sym
->assoc
);
1514 e
= sym
->assoc
->target
;
1516 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1517 && (gfc_is_class_scalar_expr (e
)
1518 || gfc_is_class_array_ref (e
, NULL
));
1520 unlimited
= UNLIMITED_POLY (e
);
1522 /* Assignments to the string length need to be generated, when
1523 ( sym is a char array or
1524 sym has a _len component)
1525 and the associated expression is unlimited polymorphic, which is
1526 not (yet) correctly in 'unlimited', because for an already associated
1527 BT_DERIVED the u-poly flag is not set, i.e.,
1528 __tmp_CHARACTER_0_1 => w => arg
1529 ^ generated temp ^ from code, the w does not have the u-poly
1530 flag set, where UNLIMITED_POLY(e) expects it. */
1531 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1532 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1533 && (sym
->ts
.type
== BT_CHARACTER
1534 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1535 && class_has_len_component (sym
))));
1536 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1537 to array temporary) for arrays with either unknown shape or if associating
1539 if (sym
->attr
.dimension
&& !class_target
1540 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1544 bool cst_array_ctor
;
1546 desc
= sym
->backend_decl
;
1547 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1548 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1550 /* If association is to an expression, evaluate it and create temporary.
1551 Otherwise, get descriptor of target for pointer assignment. */
1552 gfc_init_se (&se
, NULL
);
1553 if (sym
->assoc
->variable
|| cst_array_ctor
)
1555 se
.direct_byref
= 1;
1560 gfc_conv_expr_descriptor (&se
, e
);
1562 /* If we didn't already do the pointer assignment, set associate-name
1563 descriptor to the one generated for the temporary. */
1564 if (!sym
->assoc
->variable
&& !cst_array_ctor
)
1568 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1570 /* The generated descriptor has lower bound zero (as array
1571 temporary), shift bounds so we get lower bounds of 1. */
1572 for (dim
= 0; dim
< e
->rank
; ++dim
)
1573 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1574 dim
, gfc_index_one_node
);
1577 /* If this is a subreference array pointer associate name use the
1578 associate variable element size for the value of 'span'. */
1579 if (sym
->attr
.subref_array_pointer
)
1581 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1582 tmp
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1583 ? gfc_class_data_get (e
->symtree
->n
.sym
->backend_decl
)
1584 : e
->symtree
->n
.sym
->backend_decl
;
1585 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1586 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1587 gfc_add_modify (&se
.pre
, GFC_DECL_SPAN(desc
), tmp
);
1590 /* Done, register stuff as init / cleanup code. */
1591 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1592 gfc_finish_block (&se
.post
));
1595 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1596 arrays to be assigned directly. */
1597 else if (class_target
&& sym
->attr
.dimension
1598 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1602 gfc_init_se (&se
, NULL
);
1603 se
.descriptor_only
= 1;
1604 /* In a select type the (temporary) associate variable shall point to
1605 a standard fortran array (lower bound == 1), but conv_expr ()
1606 just maps to the input array in the class object, whose lbound may
1607 be arbitrary. conv_expr_descriptor solves this by inserting a
1608 temporary array descriptor. */
1609 gfc_conv_expr_descriptor (&se
, e
);
1611 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1612 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1613 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1615 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1617 if (INDIRECT_REF_P (se
.expr
))
1618 tmp
= TREE_OPERAND (se
.expr
, 0);
1622 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1623 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1626 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1630 /* Recover the dtype, which has been overwritten by the
1631 assignment from an unlimited polymorphic object. */
1632 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1633 gfc_add_modify (&se
.pre
, tmp
,
1634 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1637 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1638 gfc_finish_block (&se
.post
));
1641 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1642 else if (gfc_is_associate_pointer (sym
))
1646 gcc_assert (!sym
->attr
.dimension
);
1648 gfc_init_se (&se
, NULL
);
1650 /* Class associate-names come this way because they are
1651 unconditionally associate pointers and the symbol is scalar. */
1652 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1655 /* For a class array we need a descriptor for the selector. */
1656 gfc_conv_expr_descriptor (&se
, e
);
1657 /* Needed to get/set the _len component below. */
1658 target_expr
= se
.expr
;
1660 /* Obtain a temporary class container for the result. */
1661 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1662 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1664 /* Set the offset. */
1665 desc
= gfc_class_data_get (se
.expr
);
1666 offset
= gfc_index_zero_node
;
1667 for (n
= 0; n
< e
->rank
; n
++)
1669 dim
= gfc_rank_cst
[n
];
1670 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1671 gfc_array_index_type
,
1672 gfc_conv_descriptor_stride_get (desc
, dim
),
1673 gfc_conv_descriptor_lbound_get (desc
, dim
));
1674 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1675 gfc_array_index_type
,
1678 if (need_len_assign
)
1681 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1682 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1683 /* Use the original class descriptor stored in the saved
1684 descriptor to get the target_expr. */
1686 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1688 /* Strip the _data component from the target_expr. */
1689 target_expr
= TREE_OPERAND (target_expr
, 0);
1690 /* Add a reference to the _len comp to the target expr. */
1691 tmp
= gfc_class_len_get (target_expr
);
1692 /* Get the component-ref for the temp structure's _len comp. */
1693 charlen
= gfc_class_len_get (se
.expr
);
1694 /* Add the assign to the beginning of the block... */
1695 gfc_add_modify (&se
.pre
, charlen
,
1696 fold_convert (TREE_TYPE (charlen
), tmp
));
1697 /* and the oposite way at the end of the block, to hand changes
1698 on the string length back. */
1699 gfc_add_modify (&se
.post
, tmp
,
1700 fold_convert (TREE_TYPE (tmp
), charlen
));
1701 /* Length assignment done, prevent adding it again below. */
1702 need_len_assign
= false;
1704 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1706 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1707 && CLASS_DATA (e
)->attr
.dimension
)
1709 /* This is bound to be a class array element. */
1710 gfc_conv_expr_reference (&se
, e
);
1711 /* Get the _vptr component of the class object. */
1712 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1713 /* Obtain a temporary class container for the result. */
1714 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1715 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1719 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1720 which has the string length included. For CHARACTERS it is still
1721 needed and will be done at the end of this routine. */
1722 gfc_conv_expr (&se
, e
);
1723 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1726 tmp
= TREE_TYPE (sym
->backend_decl
);
1727 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1728 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1730 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1731 gfc_finish_block (&se
.post
));
1734 /* Do a simple assignment. This is for scalar expressions, where we
1735 can simply use expression assignment. */
1740 lhs
= gfc_lval_expr_from_sym (sym
);
1741 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1742 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1745 /* Set the stringlength, when needed. */
1746 if (need_len_assign
)
1749 gfc_init_se (&se
, NULL
);
1750 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1752 /* What about deferred strings? */
1753 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1754 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1757 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1758 gfc_get_symbol_decl (sym
);
1759 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1760 : gfc_class_len_get (sym
->backend_decl
);
1761 /* Prevent adding a noop len= len. */
1764 gfc_add_modify (&se
.pre
, charlen
,
1765 fold_convert (TREE_TYPE (charlen
), tmp
));
1766 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1767 gfc_finish_block (&se
.post
));
1773 /* Translate a BLOCK construct. This is basically what we would do for a
1777 gfc_trans_block_construct (gfc_code
* code
)
1781 gfc_wrapped_block block
;
1784 gfc_association_list
*ass
;
1786 ns
= code
->ext
.block
.ns
;
1788 sym
= ns
->proc_name
;
1791 /* Process local variables. */
1792 gcc_assert (!sym
->tlink
);
1794 gfc_process_block_locals (ns
);
1796 /* Generate code including exit-label. */
1797 gfc_init_block (&body
);
1798 exit_label
= gfc_build_label_decl (NULL_TREE
);
1799 code
->exit_label
= exit_label
;
1801 finish_oacc_declare (ns
, sym
, true);
1803 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1804 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1806 /* Finish everything. */
1807 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1808 gfc_trans_deferred_vars (sym
, &block
);
1809 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1810 trans_associate_var (ass
->st
->n
.sym
, &block
);
1812 return gfc_finish_wrapped_block (&block
);
1815 /* Translate the simple DO construct in a C-style manner.
1816 This is where the loop variable has integer type and step +-1.
1817 Following code will generate infinite loop in case where TO is INT_MAX
1818 (for +1 step) or INT_MIN (for -1 step)
1820 We translate a do loop from:
1822 DO dovar = from, to, step
1828 [Evaluate loop bounds and step]
1840 This helps the optimizers by avoiding the extra pre-header condition and
1841 we save a register as we just compare the updated IV (not a value in
1845 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1846 tree from
, tree to
, tree step
, tree exit_cond
)
1852 tree saved_dovar
= NULL
;
1856 type
= TREE_TYPE (dovar
);
1857 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
1859 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1861 /* Initialize the DO variable: dovar = from. */
1862 gfc_add_modify_loc (loc
, pblock
, dovar
,
1863 fold_convert (TREE_TYPE (dovar
), from
));
1865 /* Save value for do-tinkering checking. */
1866 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1868 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1869 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1872 /* Cycle and exit statements are implemented with gotos. */
1873 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1874 exit_label
= gfc_build_label_decl (NULL_TREE
);
1876 /* Put the labels where they can be found later. See gfc_trans_do(). */
1877 code
->cycle_label
= cycle_label
;
1878 code
->exit_label
= exit_label
;
1881 gfc_start_block (&body
);
1883 /* Exit the loop if there is an I/O result condition or error. */
1886 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1887 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1889 build_empty_stmt (loc
));
1890 gfc_add_expr_to_block (&body
, tmp
);
1893 /* Evaluate the loop condition. */
1894 if (is_step_positive
)
1895 cond
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, dovar
,
1896 fold_convert (type
, to
));
1898 cond
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, dovar
,
1899 fold_convert (type
, to
));
1901 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1903 /* The loop exit. */
1904 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1905 TREE_USED (exit_label
) = 1;
1906 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1907 cond
, tmp
, build_empty_stmt (loc
));
1908 gfc_add_expr_to_block (&body
, tmp
);
1910 /* Check whether the induction variable is equal to INT_MAX
1911 (respectively to INT_MIN). */
1912 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1914 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
1915 : TYPE_MIN_VALUE (type
);
1917 tmp
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
,
1919 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1920 "Loop iterates infinitely");
1923 /* Main loop body. */
1924 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1925 gfc_add_expr_to_block (&body
, tmp
);
1927 /* Label for cycle statements (if needed). */
1928 if (TREE_USED (cycle_label
))
1930 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1931 gfc_add_expr_to_block (&body
, tmp
);
1934 /* Check whether someone has modified the loop variable. */
1935 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1937 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
1938 dovar
, saved_dovar
);
1939 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1940 "Loop variable has been modified");
1943 /* Increment the loop variable. */
1944 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1945 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1947 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1948 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1950 /* Finish the loop body. */
1951 tmp
= gfc_finish_block (&body
);
1952 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1954 gfc_add_expr_to_block (pblock
, tmp
);
1956 /* Add the exit label. */
1957 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1958 gfc_add_expr_to_block (pblock
, tmp
);
1960 return gfc_finish_block (pblock
);
1963 /* Translate the DO construct. This obviously is one of the most
1964 important ones to get right with any compiler, but especially
1967 We special case some loop forms as described in gfc_trans_simple_do.
1968 For other cases we implement them with a separate loop count,
1969 as described in the standard.
1971 We translate a do loop from:
1973 DO dovar = from, to, step
1979 [evaluate loop bounds and step]
1980 empty = (step > 0 ? to < from : to > from);
1981 countm1 = (to - from) / step;
1983 if (empty) goto exit_label;
1991 if (countm1t == 0) goto exit_label;
1995 countm1 is an unsigned integer. It is equal to the loop count minus one,
1996 because the loop count itself can overflow. */
1999 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2003 tree saved_dovar
= NULL
;
2018 gfc_start_block (&block
);
2020 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2022 /* Evaluate all the expressions in the iterator. */
2023 gfc_init_se (&se
, NULL
);
2024 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2025 gfc_add_block_to_block (&block
, &se
.pre
);
2027 type
= TREE_TYPE (dovar
);
2029 gfc_init_se (&se
, NULL
);
2030 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2031 gfc_add_block_to_block (&block
, &se
.pre
);
2032 from
= gfc_evaluate_now (se
.expr
, &block
);
2034 gfc_init_se (&se
, NULL
);
2035 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2036 gfc_add_block_to_block (&block
, &se
.pre
);
2037 to
= gfc_evaluate_now (se
.expr
, &block
);
2039 gfc_init_se (&se
, NULL
);
2040 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2041 gfc_add_block_to_block (&block
, &se
.pre
);
2042 step
= gfc_evaluate_now (se
.expr
, &block
);
2044 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2046 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
2047 build_zero_cst (type
));
2048 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2049 "DO step value is zero");
2052 /* Special case simple loops. */
2053 if (TREE_CODE (type
) == INTEGER_TYPE
2054 && (integer_onep (step
)
2055 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2056 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2059 if (TREE_CODE (type
) == INTEGER_TYPE
)
2060 utype
= unsigned_type_for (type
);
2062 utype
= unsigned_type_for (gfc_array_index_type
);
2063 countm1
= gfc_create_var (utype
, "countm1");
2065 /* Cycle and exit statements are implemented with gotos. */
2066 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2067 exit_label
= gfc_build_label_decl (NULL_TREE
);
2068 TREE_USED (exit_label
) = 1;
2070 /* Put these labels where they can be found later. */
2071 code
->cycle_label
= cycle_label
;
2072 code
->exit_label
= exit_label
;
2074 /* Initialize the DO variable: dovar = from. */
2075 gfc_add_modify (&block
, dovar
, from
);
2077 /* Save value for do-tinkering checking. */
2078 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2080 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2081 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2084 /* Initialize loop count and jump to exit label if the loop is empty.
2085 This code is executed before we enter the loop body. We generate:
2088 countm1 = (to - from) / step;
2094 countm1 = (from - to) / -step;
2100 if (TREE_CODE (type
) == INTEGER_TYPE
)
2102 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2104 /* The distance from FROM to TO cannot always be represented in a signed
2105 type, thus use unsigned arithmetic, also to avoid any undefined
2107 tou
= fold_convert (utype
, to
);
2108 fromu
= fold_convert (utype
, from
);
2109 stepu
= fold_convert (utype
, step
);
2111 /* For a positive step, when to < from, exit, otherwise compute
2112 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2113 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
2114 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2115 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2118 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2119 fold_build2 (MODIFY_EXPR
, void_type_node
,
2121 build3_loc (loc
, COND_EXPR
, void_type_node
,
2122 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2123 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2124 exit_label
), NULL_TREE
));
2126 /* For a negative step, when to > from, exit, otherwise compute
2127 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2128 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
2129 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2130 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2132 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2133 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2134 fold_build2 (MODIFY_EXPR
, void_type_node
,
2136 build3_loc (loc
, COND_EXPR
, void_type_node
,
2137 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2138 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2139 exit_label
), NULL_TREE
));
2141 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
2142 build_int_cst (TREE_TYPE (step
), 0));
2143 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2145 gfc_add_expr_to_block (&block
, tmp
);
2151 /* TODO: We could use the same width as the real type.
2152 This would probably cause more problems that it solves
2153 when we implement "long double" types. */
2155 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2156 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2157 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2158 gfc_add_modify (&block
, countm1
, tmp
);
2160 /* We need a special check for empty loops:
2161 empty = (step > 0 ? to < from : to > from); */
2162 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
2163 build_zero_cst (type
));
2164 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
2165 fold_build2_loc (loc
, LT_EXPR
,
2166 boolean_type_node
, to
, from
),
2167 fold_build2_loc (loc
, GT_EXPR
,
2168 boolean_type_node
, to
, from
));
2169 /* If the loop is empty, go directly to the exit label. */
2170 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2171 build1_v (GOTO_EXPR
, exit_label
),
2172 build_empty_stmt (input_location
));
2173 gfc_add_expr_to_block (&block
, tmp
);
2177 gfc_start_block (&body
);
2179 /* Main loop body. */
2180 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2181 gfc_add_expr_to_block (&body
, tmp
);
2183 /* Label for cycle statements (if needed). */
2184 if (TREE_USED (cycle_label
))
2186 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2187 gfc_add_expr_to_block (&body
, tmp
);
2190 /* Check whether someone has modified the loop variable. */
2191 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2193 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
2195 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2196 "Loop variable has been modified");
2199 /* Exit the loop if there is an I/O result condition or error. */
2202 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2203 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2205 build_empty_stmt (input_location
));
2206 gfc_add_expr_to_block (&body
, tmp
);
2209 /* Increment the loop variable. */
2210 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2211 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2213 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2214 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2216 /* Initialize countm1t. */
2217 tree countm1t
= gfc_create_var (utype
, "countm1t");
2218 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2220 /* Decrement the loop count. */
2221 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2222 build_int_cst (utype
, 1));
2223 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2225 /* End with the loop condition. Loop until countm1t == 0. */
2226 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
2227 build_int_cst (utype
, 0));
2228 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2229 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2230 cond
, tmp
, build_empty_stmt (loc
));
2231 gfc_add_expr_to_block (&body
, tmp
);
2233 /* End of loop body. */
2234 tmp
= gfc_finish_block (&body
);
2236 /* The for loop itself. */
2237 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2238 gfc_add_expr_to_block (&block
, tmp
);
2240 /* Add the exit label. */
2241 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2242 gfc_add_expr_to_block (&block
, tmp
);
2244 return gfc_finish_block (&block
);
2248 /* Translate the DO WHILE construct.
2261 if (! cond) goto exit_label;
2267 Because the evaluation of the exit condition `cond' may have side
2268 effects, we can't do much for empty loop bodies. The backend optimizers
2269 should be smart enough to eliminate any dead loops. */
2272 gfc_trans_do_while (gfc_code
* code
)
2280 /* Everything we build here is part of the loop body. */
2281 gfc_start_block (&block
);
2283 /* Cycle and exit statements are implemented with gotos. */
2284 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2285 exit_label
= gfc_build_label_decl (NULL_TREE
);
2287 /* Put the labels where they can be found later. See gfc_trans_do(). */
2288 code
->cycle_label
= cycle_label
;
2289 code
->exit_label
= exit_label
;
2291 /* Create a GIMPLE version of the exit condition. */
2292 gfc_init_se (&cond
, NULL
);
2293 gfc_conv_expr_val (&cond
, code
->expr1
);
2294 gfc_add_block_to_block (&block
, &cond
.pre
);
2295 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2296 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2298 /* Build "IF (! cond) GOTO exit_label". */
2299 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2300 TREE_USED (exit_label
) = 1;
2301 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2302 void_type_node
, cond
.expr
, tmp
,
2303 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2304 gfc_add_expr_to_block (&block
, tmp
);
2306 /* The main body of the loop. */
2307 tmp
= gfc_trans_code (code
->block
->next
);
2308 gfc_add_expr_to_block (&block
, tmp
);
2310 /* Label for cycle statements (if needed). */
2311 if (TREE_USED (cycle_label
))
2313 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2314 gfc_add_expr_to_block (&block
, tmp
);
2317 /* End of loop body. */
2318 tmp
= gfc_finish_block (&block
);
2320 gfc_init_block (&block
);
2321 /* Build the loop. */
2322 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2323 void_type_node
, tmp
);
2324 gfc_add_expr_to_block (&block
, tmp
);
2326 /* Add the exit label. */
2327 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2328 gfc_add_expr_to_block (&block
, tmp
);
2330 return gfc_finish_block (&block
);
2334 /* Deal with the particular case of SELECT_TYPE, where the vtable
2335 addresses are used for the selection. Since these are not sorted,
2336 the selection has to be made by a series of if statements. */
2339 gfc_trans_select_type_cases (gfc_code
* code
)
2353 gfc_start_block (&block
);
2355 /* Calculate the switch expression. */
2356 gfc_init_se (&se
, NULL
);
2357 gfc_conv_expr_val (&se
, code
->expr1
);
2358 gfc_add_block_to_block (&block
, &se
.pre
);
2360 /* Generate an expression for the selector hash value, for
2361 use to resolve character cases. */
2362 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2363 gfc_add_hash_component (e
);
2365 TREE_USED (code
->exit_label
) = 0;
2368 for (c
= code
->block
; c
; c
= c
->block
)
2370 cp
= c
->ext
.block
.case_list
;
2372 /* Assume it's the default case. */
2377 /* Put the default case at the end. */
2378 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2381 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2382 || cp
->ts
.type
== BT_DERIVED
))
2384 gfc_init_se (&cse
, NULL
);
2385 gfc_conv_expr_val (&cse
, cp
->low
);
2386 gfc_add_block_to_block (&block
, &cse
.pre
);
2389 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2391 gcc_assert (cp
->high
);
2392 gfc_init_se (&cse
, NULL
);
2393 gfc_conv_expr_val (&cse
, cp
->high
);
2394 gfc_add_block_to_block (&block
, &cse
.pre
);
2398 gfc_init_block (&body
);
2400 /* Add the statements for this case. */
2401 tmp
= gfc_trans_code (c
->next
);
2402 gfc_add_expr_to_block (&body
, tmp
);
2404 /* Break to the end of the SELECT TYPE construct. The default
2405 case just falls through. */
2408 TREE_USED (code
->exit_label
) = 1;
2409 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2410 gfc_add_expr_to_block (&body
, tmp
);
2413 tmp
= gfc_finish_block (&body
);
2415 if (low
!= NULL_TREE
)
2417 /* Compare vtable pointers. */
2418 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2419 TREE_TYPE (se
.expr
), se
.expr
, low
);
2420 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2422 build_empty_stmt (input_location
));
2424 else if (high
!= NULL_TREE
)
2426 /* Compare hash values for character cases. */
2427 gfc_init_se (&cse
, NULL
);
2428 gfc_conv_expr_val (&cse
, e
);
2429 gfc_add_block_to_block (&block
, &cse
.pre
);
2431 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2432 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2433 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2435 build_empty_stmt (input_location
));
2438 gfc_add_expr_to_block (&block
, tmp
);
2449 return gfc_finish_block (&block
);
2453 /* Translate the SELECT CASE construct for INTEGER case expressions,
2454 without killing all potential optimizations. The problem is that
2455 Fortran allows unbounded cases, but the back-end does not, so we
2456 need to intercept those before we enter the equivalent SWITCH_EXPR
2459 For example, we translate this,
2462 CASE (:100,101,105:115)
2472 to the GENERIC equivalent,
2476 case (minimum value for typeof(expr) ... 100:
2482 case 200 ... (maximum value for typeof(expr):
2499 gfc_trans_integer_select (gfc_code
* code
)
2509 gfc_start_block (&block
);
2511 /* Calculate the switch expression. */
2512 gfc_init_se (&se
, NULL
);
2513 gfc_conv_expr_val (&se
, code
->expr1
);
2514 gfc_add_block_to_block (&block
, &se
.pre
);
2516 end_label
= gfc_build_label_decl (NULL_TREE
);
2518 gfc_init_block (&body
);
2520 for (c
= code
->block
; c
; c
= c
->block
)
2522 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2527 /* Assume it's the default case. */
2528 low
= high
= NULL_TREE
;
2532 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2535 /* If there's only a lower bound, set the high bound to the
2536 maximum value of the case expression. */
2538 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2543 /* Three cases are possible here:
2545 1) There is no lower bound, e.g. CASE (:N).
2546 2) There is a lower bound .NE. high bound, that is
2547 a case range, e.g. CASE (N:M) where M>N (we make
2548 sure that M>N during type resolution).
2549 3) There is a lower bound, and it has the same value
2550 as the high bound, e.g. CASE (N:N). This is our
2551 internal representation of CASE(N).
2553 In the first and second case, we need to set a value for
2554 high. In the third case, we don't because the GCC middle
2555 end represents a single case value by just letting high be
2556 a NULL_TREE. We can't do that because we need to be able
2557 to represent unbounded cases. */
2561 && mpz_cmp (cp
->low
->value
.integer
,
2562 cp
->high
->value
.integer
) != 0))
2563 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2566 /* Unbounded case. */
2568 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2571 /* Build a label. */
2572 label
= gfc_build_label_decl (NULL_TREE
);
2574 /* Add this case label.
2575 Add parameter 'label', make it match GCC backend. */
2576 tmp
= build_case_label (low
, high
, label
);
2577 gfc_add_expr_to_block (&body
, tmp
);
2580 /* Add the statements for this case. */
2581 tmp
= gfc_trans_code (c
->next
);
2582 gfc_add_expr_to_block (&body
, tmp
);
2584 /* Break to the end of the construct. */
2585 tmp
= build1_v (GOTO_EXPR
, end_label
);
2586 gfc_add_expr_to_block (&body
, tmp
);
2589 tmp
= gfc_finish_block (&body
);
2590 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2591 se
.expr
, tmp
, NULL_TREE
);
2592 gfc_add_expr_to_block (&block
, tmp
);
2594 tmp
= build1_v (LABEL_EXPR
, end_label
);
2595 gfc_add_expr_to_block (&block
, tmp
);
2597 return gfc_finish_block (&block
);
2601 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2603 There are only two cases possible here, even though the standard
2604 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2605 .FALSE., and DEFAULT.
2607 We never generate more than two blocks here. Instead, we always
2608 try to eliminate the DEFAULT case. This way, we can translate this
2609 kind of SELECT construct to a simple
2613 expression in GENERIC. */
2616 gfc_trans_logical_select (gfc_code
* code
)
2619 gfc_code
*t
, *f
, *d
;
2624 /* Assume we don't have any cases at all. */
2627 /* Now see which ones we actually do have. We can have at most two
2628 cases in a single case list: one for .TRUE. and one for .FALSE.
2629 The default case is always separate. If the cases for .TRUE. and
2630 .FALSE. are in the same case list, the block for that case list
2631 always executed, and we don't generate code a COND_EXPR. */
2632 for (c
= code
->block
; c
; c
= c
->block
)
2634 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2638 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2640 else /* if (cp->value.logical != 0), thus .TRUE. */
2648 /* Start a new block. */
2649 gfc_start_block (&block
);
2651 /* Calculate the switch expression. We always need to do this
2652 because it may have side effects. */
2653 gfc_init_se (&se
, NULL
);
2654 gfc_conv_expr_val (&se
, code
->expr1
);
2655 gfc_add_block_to_block (&block
, &se
.pre
);
2657 if (t
== f
&& t
!= NULL
)
2659 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2660 translate the code for these cases, append it to the current
2662 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2666 tree true_tree
, false_tree
, stmt
;
2668 true_tree
= build_empty_stmt (input_location
);
2669 false_tree
= build_empty_stmt (input_location
);
2671 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2672 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2673 make the missing case the default case. */
2674 if (t
!= NULL
&& f
!= NULL
)
2684 /* Translate the code for each of these blocks, and append it to
2685 the current block. */
2687 true_tree
= gfc_trans_code (t
->next
);
2690 false_tree
= gfc_trans_code (f
->next
);
2692 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2693 se
.expr
, true_tree
, false_tree
);
2694 gfc_add_expr_to_block (&block
, stmt
);
2697 return gfc_finish_block (&block
);
2701 /* The jump table types are stored in static variables to avoid
2702 constructing them from scratch every single time. */
2703 static GTY(()) tree select_struct
[2];
2705 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2706 Instead of generating compares and jumps, it is far simpler to
2707 generate a data structure describing the cases in order and call a
2708 library subroutine that locates the right case.
2709 This is particularly true because this is the only case where we
2710 might have to dispose of a temporary.
2711 The library subroutine returns a pointer to jump to or NULL if no
2712 branches are to be taken. */
2715 gfc_trans_character_select (gfc_code
*code
)
2717 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2718 stmtblock_t block
, body
;
2723 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2725 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2727 /* The jump table types are stored in static variables to avoid
2728 constructing them from scratch every single time. */
2729 static tree ss_string1
[2], ss_string1_len
[2];
2730 static tree ss_string2
[2], ss_string2_len
[2];
2731 static tree ss_target
[2];
2733 cp
= code
->block
->ext
.block
.case_list
;
2734 while (cp
->left
!= NULL
)
2737 /* Generate the body */
2738 gfc_start_block (&block
);
2739 gfc_init_se (&expr1se
, NULL
);
2740 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2742 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2744 end_label
= gfc_build_label_decl (NULL_TREE
);
2746 gfc_init_block (&body
);
2748 /* Attempt to optimize length 1 selects. */
2749 if (integer_onep (expr1se
.string_length
))
2751 for (d
= cp
; d
; d
= d
->right
)
2756 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2757 && d
->low
->ts
.type
== BT_CHARACTER
);
2758 if (d
->low
->value
.character
.length
> 1)
2760 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2761 if (d
->low
->value
.character
.string
[i
] != ' ')
2763 if (i
!= d
->low
->value
.character
.length
)
2765 if (optimize
&& d
->high
&& i
== 1)
2767 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2768 && d
->high
->ts
.type
== BT_CHARACTER
);
2769 if (d
->high
->value
.character
.length
> 1
2770 && (d
->low
->value
.character
.string
[0]
2771 == d
->high
->value
.character
.string
[0])
2772 && d
->high
->value
.character
.string
[1] != ' '
2773 && ((d
->low
->value
.character
.string
[1] < ' ')
2774 == (d
->high
->value
.character
.string
[1]
2784 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2785 && d
->high
->ts
.type
== BT_CHARACTER
);
2786 if (d
->high
->value
.character
.length
> 1)
2788 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2789 if (d
->high
->value
.character
.string
[i
] != ' ')
2791 if (i
!= d
->high
->value
.character
.length
)
2798 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2800 for (c
= code
->block
; c
; c
= c
->block
)
2802 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2808 /* Assume it's the default case. */
2809 low
= high
= NULL_TREE
;
2813 /* CASE ('ab') or CASE ('ab':'az') will never match
2814 any length 1 character. */
2815 if (cp
->low
->value
.character
.length
> 1
2816 && cp
->low
->value
.character
.string
[1] != ' ')
2819 if (cp
->low
->value
.character
.length
> 0)
2820 r
= cp
->low
->value
.character
.string
[0];
2823 low
= build_int_cst (ctype
, r
);
2825 /* If there's only a lower bound, set the high bound
2826 to the maximum value of the case expression. */
2828 high
= TYPE_MAX_VALUE (ctype
);
2834 || (cp
->low
->value
.character
.string
[0]
2835 != cp
->high
->value
.character
.string
[0]))
2837 if (cp
->high
->value
.character
.length
> 0)
2838 r
= cp
->high
->value
.character
.string
[0];
2841 high
= build_int_cst (ctype
, r
);
2844 /* Unbounded case. */
2846 low
= TYPE_MIN_VALUE (ctype
);
2849 /* Build a label. */
2850 label
= gfc_build_label_decl (NULL_TREE
);
2852 /* Add this case label.
2853 Add parameter 'label', make it match GCC backend. */
2854 tmp
= build_case_label (low
, high
, label
);
2855 gfc_add_expr_to_block (&body
, tmp
);
2858 /* Add the statements for this case. */
2859 tmp
= gfc_trans_code (c
->next
);
2860 gfc_add_expr_to_block (&body
, tmp
);
2862 /* Break to the end of the construct. */
2863 tmp
= build1_v (GOTO_EXPR
, end_label
);
2864 gfc_add_expr_to_block (&body
, tmp
);
2867 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2869 code
->expr1
->ts
.kind
);
2870 case_num
= gfc_create_var (ctype
, "case_num");
2871 gfc_add_modify (&block
, case_num
, tmp
);
2873 gfc_add_block_to_block (&block
, &expr1se
.post
);
2875 tmp
= gfc_finish_block (&body
);
2876 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2877 case_num
, tmp
, NULL_TREE
);
2878 gfc_add_expr_to_block (&block
, tmp
);
2880 tmp
= build1_v (LABEL_EXPR
, end_label
);
2881 gfc_add_expr_to_block (&block
, tmp
);
2883 return gfc_finish_block (&block
);
2887 if (code
->expr1
->ts
.kind
== 1)
2889 else if (code
->expr1
->ts
.kind
== 4)
2894 if (select_struct
[k
] == NULL
)
2897 select_struct
[k
] = make_node (RECORD_TYPE
);
2899 if (code
->expr1
->ts
.kind
== 1)
2900 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2901 else if (code
->expr1
->ts
.kind
== 4)
2902 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2907 #define ADD_FIELD(NAME, TYPE) \
2908 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2909 get_identifier (stringize(NAME)), \
2913 ADD_FIELD (string1
, pchartype
);
2914 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2916 ADD_FIELD (string2
, pchartype
);
2917 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2919 ADD_FIELD (target
, integer_type_node
);
2922 gfc_finish_type (select_struct
[k
]);
2926 for (d
= cp
; d
; d
= d
->right
)
2929 for (c
= code
->block
; c
; c
= c
->block
)
2931 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
2933 label
= gfc_build_label_decl (NULL_TREE
);
2934 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
2936 : build_int_cst (integer_type_node
, d
->n
),
2938 gfc_add_expr_to_block (&body
, tmp
);
2941 tmp
= gfc_trans_code (c
->next
);
2942 gfc_add_expr_to_block (&body
, tmp
);
2944 tmp
= build1_v (GOTO_EXPR
, end_label
);
2945 gfc_add_expr_to_block (&body
, tmp
);
2948 /* Generate the structure describing the branches */
2949 for (d
= cp
; d
; d
= d
->right
)
2951 vec
<constructor_elt
, va_gc
> *node
= NULL
;
2953 gfc_init_se (&se
, NULL
);
2957 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
2958 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
2962 gfc_conv_expr_reference (&se
, d
->low
);
2964 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
2965 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
2968 if (d
->high
== NULL
)
2970 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
2971 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
2975 gfc_init_se (&se
, NULL
);
2976 gfc_conv_expr_reference (&se
, d
->high
);
2978 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
2979 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
2982 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
2983 build_int_cst (integer_type_node
, d
->n
));
2985 tmp
= build_constructor (select_struct
[k
], node
);
2986 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
2989 type
= build_array_type (select_struct
[k
],
2990 build_index_type (size_int (n
-1)));
2992 init
= build_constructor (type
, inits
);
2993 TREE_CONSTANT (init
) = 1;
2994 TREE_STATIC (init
) = 1;
2995 /* Create a static variable to hold the jump table. */
2996 tmp
= gfc_create_var (type
, "jumptable");
2997 TREE_CONSTANT (tmp
) = 1;
2998 TREE_STATIC (tmp
) = 1;
2999 TREE_READONLY (tmp
) = 1;
3000 DECL_INITIAL (tmp
) = init
;
3003 /* Build the library call */
3004 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3006 if (code
->expr1
->ts
.kind
== 1)
3007 fndecl
= gfor_fndecl_select_string
;
3008 else if (code
->expr1
->ts
.kind
== 4)
3009 fndecl
= gfor_fndecl_select_string_char4
;
3013 tmp
= build_call_expr_loc (input_location
,
3015 build_int_cst (gfc_charlen_type_node
, n
),
3016 expr1se
.expr
, expr1se
.string_length
);
3017 case_num
= gfc_create_var (integer_type_node
, "case_num");
3018 gfc_add_modify (&block
, case_num
, tmp
);
3020 gfc_add_block_to_block (&block
, &expr1se
.post
);
3022 tmp
= gfc_finish_block (&body
);
3023 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3024 case_num
, tmp
, NULL_TREE
);
3025 gfc_add_expr_to_block (&block
, tmp
);
3027 tmp
= build1_v (LABEL_EXPR
, end_label
);
3028 gfc_add_expr_to_block (&block
, tmp
);
3030 return gfc_finish_block (&block
);
3034 /* Translate the three variants of the SELECT CASE construct.
3036 SELECT CASEs with INTEGER case expressions can be translated to an
3037 equivalent GENERIC switch statement, and for LOGICAL case
3038 expressions we build one or two if-else compares.
3040 SELECT CASEs with CHARACTER case expressions are a whole different
3041 story, because they don't exist in GENERIC. So we sort them and
3042 do a binary search at runtime.
3044 Fortran has no BREAK statement, and it does not allow jumps from
3045 one case block to another. That makes things a lot easier for
3049 gfc_trans_select (gfc_code
* code
)
3055 gcc_assert (code
&& code
->expr1
);
3056 gfc_init_block (&block
);
3058 /* Build the exit label and hang it in. */
3059 exit_label
= gfc_build_label_decl (NULL_TREE
);
3060 code
->exit_label
= exit_label
;
3062 /* Empty SELECT constructs are legal. */
3063 if (code
->block
== NULL
)
3064 body
= build_empty_stmt (input_location
);
3066 /* Select the correct translation function. */
3068 switch (code
->expr1
->ts
.type
)
3071 body
= gfc_trans_logical_select (code
);
3075 body
= gfc_trans_integer_select (code
);
3079 body
= gfc_trans_character_select (code
);
3083 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3087 /* Build everything together. */
3088 gfc_add_expr_to_block (&block
, body
);
3089 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3091 return gfc_finish_block (&block
);
3095 gfc_trans_select_type (gfc_code
* code
)
3101 gcc_assert (code
&& code
->expr1
);
3102 gfc_init_block (&block
);
3104 /* Build the exit label and hang it in. */
3105 exit_label
= gfc_build_label_decl (NULL_TREE
);
3106 code
->exit_label
= exit_label
;
3108 /* Empty SELECT constructs are legal. */
3109 if (code
->block
== NULL
)
3110 body
= build_empty_stmt (input_location
);
3112 body
= gfc_trans_select_type_cases (code
);
3114 /* Build everything together. */
3115 gfc_add_expr_to_block (&block
, body
);
3117 if (TREE_USED (exit_label
))
3118 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3120 return gfc_finish_block (&block
);
3124 /* Traversal function to substitute a replacement symtree if the symbol
3125 in the expression is the same as that passed. f == 2 signals that
3126 that variable itself is not to be checked - only the references.
3127 This group of functions is used when the variable expression in a
3128 FORALL assignment has internal references. For example:
3129 FORALL (i = 1:4) p(p(i)) = i
3130 The only recourse here is to store a copy of 'p' for the index
3133 static gfc_symtree
*new_symtree
;
3134 static gfc_symtree
*old_symtree
;
3137 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3139 if (expr
->expr_type
!= EXPR_VARIABLE
)
3144 else if (expr
->symtree
->n
.sym
== sym
)
3145 expr
->symtree
= new_symtree
;
3151 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3153 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3157 forall_restore (gfc_expr
*expr
,
3158 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3159 int *f ATTRIBUTE_UNUSED
)
3161 if (expr
->expr_type
!= EXPR_VARIABLE
)
3164 if (expr
->symtree
== new_symtree
)
3165 expr
->symtree
= old_symtree
;
3171 forall_restore_symtree (gfc_expr
*e
)
3173 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3177 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3182 gfc_symbol
*new_sym
;
3183 gfc_symbol
*old_sym
;
3187 /* Build a copy of the lvalue. */
3188 old_symtree
= c
->expr1
->symtree
;
3189 old_sym
= old_symtree
->n
.sym
;
3190 e
= gfc_lval_expr_from_sym (old_sym
);
3191 if (old_sym
->attr
.dimension
)
3193 gfc_init_se (&tse
, NULL
);
3194 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3195 gfc_add_block_to_block (pre
, &tse
.pre
);
3196 gfc_add_block_to_block (post
, &tse
.post
);
3197 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3199 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3201 /* Use the variable offset for the temporary. */
3202 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3203 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3208 gfc_init_se (&tse
, NULL
);
3209 gfc_init_se (&rse
, NULL
);
3210 gfc_conv_expr (&rse
, e
);
3211 if (e
->ts
.type
== BT_CHARACTER
)
3213 tse
.string_length
= rse
.string_length
;
3214 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3216 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3218 gfc_add_block_to_block (pre
, &tse
.pre
);
3219 gfc_add_block_to_block (post
, &tse
.post
);
3223 tmp
= gfc_typenode_for_spec (&e
->ts
);
3224 tse
.expr
= gfc_create_var (tmp
, "temp");
3227 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3228 e
->expr_type
== EXPR_VARIABLE
, false);
3229 gfc_add_expr_to_block (pre
, tmp
);
3233 /* Create a new symbol to represent the lvalue. */
3234 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3235 new_sym
->ts
= old_sym
->ts
;
3236 new_sym
->attr
.referenced
= 1;
3237 new_sym
->attr
.temporary
= 1;
3238 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3239 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3241 /* Use the temporary as the backend_decl. */
3242 new_sym
->backend_decl
= tse
.expr
;
3244 /* Create a fake symtree for it. */
3246 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3247 new_symtree
->n
.sym
= new_sym
;
3248 gcc_assert (new_symtree
== root
);
3250 /* Go through the expression reference replacing the old_symtree
3252 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3254 /* Now we have made this temporary, we might as well use it for
3255 the right hand side. */
3256 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3260 /* Handles dependencies in forall assignments. */
3262 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3269 lsym
= c
->expr1
->symtree
->n
.sym
;
3270 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3272 /* Now check for dependencies within the 'variable'
3273 expression itself. These are treated by making a complete
3274 copy of variable and changing all the references to it
3275 point to the copy instead. Note that the shallow copy of
3276 the variable will not suffice for derived types with
3277 pointer components. We therefore leave these to their
3279 if (lsym
->ts
.type
== BT_DERIVED
3280 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3284 if (find_forall_index (c
->expr1
, lsym
, 2))
3286 forall_make_variable_temp (c
, pre
, post
);
3290 /* Substrings with dependencies are treated in the same
3292 if (c
->expr1
->ts
.type
== BT_CHARACTER
3294 && c
->expr2
->expr_type
== EXPR_VARIABLE
3295 && lsym
== c
->expr2
->symtree
->n
.sym
)
3297 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3298 if (lref
->type
== REF_SUBSTRING
)
3300 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3301 if (rref
->type
== REF_SUBSTRING
)
3305 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3307 forall_make_variable_temp (c
, pre
, post
);
3316 cleanup_forall_symtrees (gfc_code
*c
)
3318 forall_restore_symtree (c
->expr1
);
3319 forall_restore_symtree (c
->expr2
);
3320 free (new_symtree
->n
.sym
);
3325 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3326 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3327 indicates whether we should generate code to test the FORALLs mask
3328 array. OUTER is the loop header to be used for initializing mask
3331 The generated loop format is:
3332 count = (end - start + step) / step
3345 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3346 int mask_flag
, stmtblock_t
*outer
)
3354 tree var
, start
, end
, step
;
3357 /* Initialize the mask index outside the FORALL nest. */
3358 if (mask_flag
&& forall_tmp
->mask
)
3359 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3361 iter
= forall_tmp
->this_loop
;
3362 nvar
= forall_tmp
->nvar
;
3363 for (n
= 0; n
< nvar
; n
++)
3366 start
= iter
->start
;
3370 exit_label
= gfc_build_label_decl (NULL_TREE
);
3371 TREE_USED (exit_label
) = 1;
3373 /* The loop counter. */
3374 count
= gfc_create_var (TREE_TYPE (var
), "count");
3376 /* The body of the loop. */
3377 gfc_init_block (&block
);
3379 /* The exit condition. */
3380 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3381 count
, build_int_cst (TREE_TYPE (count
), 0));
3382 if (forall_tmp
->do_concurrent
)
3383 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3384 build_int_cst (integer_type_node
,
3385 annot_expr_ivdep_kind
));
3387 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3388 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3389 cond
, tmp
, build_empty_stmt (input_location
));
3390 gfc_add_expr_to_block (&block
, tmp
);
3392 /* The main loop body. */
3393 gfc_add_expr_to_block (&block
, body
);
3395 /* Increment the loop variable. */
3396 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3398 gfc_add_modify (&block
, var
, tmp
);
3400 /* Advance to the next mask element. Only do this for the
3402 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3404 tree maskindex
= forall_tmp
->maskindex
;
3405 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3406 maskindex
, gfc_index_one_node
);
3407 gfc_add_modify (&block
, maskindex
, tmp
);
3410 /* Decrement the loop counter. */
3411 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3412 build_int_cst (TREE_TYPE (var
), 1));
3413 gfc_add_modify (&block
, count
, tmp
);
3415 body
= gfc_finish_block (&block
);
3417 /* Loop var initialization. */
3418 gfc_init_block (&block
);
3419 gfc_add_modify (&block
, var
, start
);
3422 /* Initialize the loop counter. */
3423 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3425 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3427 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3429 gfc_add_modify (&block
, count
, tmp
);
3431 /* The loop expression. */
3432 tmp
= build1_v (LOOP_EXPR
, body
);
3433 gfc_add_expr_to_block (&block
, tmp
);
3435 /* The exit label. */
3436 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3437 gfc_add_expr_to_block (&block
, tmp
);
3439 body
= gfc_finish_block (&block
);
3446 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3447 is nonzero, the body is controlled by all masks in the forall nest.
3448 Otherwise, the innermost loop is not controlled by it's mask. This
3449 is used for initializing that mask. */
3452 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3457 forall_info
*forall_tmp
;
3458 tree mask
, maskindex
;
3460 gfc_start_block (&header
);
3462 forall_tmp
= nested_forall_info
;
3463 while (forall_tmp
!= NULL
)
3465 /* Generate body with masks' control. */
3468 mask
= forall_tmp
->mask
;
3469 maskindex
= forall_tmp
->maskindex
;
3471 /* If a mask was specified make the assignment conditional. */
3474 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3475 body
= build3_v (COND_EXPR
, tmp
, body
,
3476 build_empty_stmt (input_location
));
3479 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3480 forall_tmp
= forall_tmp
->prev_nest
;
3484 gfc_add_expr_to_block (&header
, body
);
3485 return gfc_finish_block (&header
);
3489 /* Allocate data for holding a temporary array. Returns either a local
3490 temporary array or a pointer variable. */
3493 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3500 if (INTEGER_CST_P (size
))
3501 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3502 size
, gfc_index_one_node
);
3506 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3507 type
= build_array_type (elem_type
, type
);
3508 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3510 tmpvar
= gfc_create_var (type
, "temp");
3515 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3516 *pdata
= convert (pvoid_type_node
, tmpvar
);
3518 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3519 gfc_add_modify (pblock
, tmpvar
, tmp
);
3525 /* Generate codes to copy the temporary to the actual lhs. */
3528 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3530 gfc_ss
*lss
, gfc_ss
*rss
,
3531 tree wheremask
, bool invert
)
3533 stmtblock_t block
, body1
;
3540 (void) rss
; /* TODO: unused. */
3542 gfc_start_block (&block
);
3544 gfc_init_se (&rse
, NULL
);
3545 gfc_init_se (&lse
, NULL
);
3547 if (lss
== gfc_ss_terminator
)
3549 gfc_init_block (&body1
);
3550 gfc_conv_expr (&lse
, expr
);
3551 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3555 /* Initialize the loop. */
3556 gfc_init_loopinfo (&loop
);
3558 /* We may need LSS to determine the shape of the expression. */
3559 gfc_add_ss_to_loop (&loop
, lss
);
3561 gfc_conv_ss_startstride (&loop
);
3562 gfc_conv_loop_setup (&loop
, &expr
->where
);
3564 gfc_mark_ss_chain_used (lss
, 1);
3565 /* Start the loop body. */
3566 gfc_start_scalarized_body (&loop
, &body1
);
3568 /* Translate the expression. */
3569 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3571 gfc_conv_expr (&lse
, expr
);
3573 /* Form the expression of the temporary. */
3574 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3577 /* Use the scalar assignment. */
3578 rse
.string_length
= lse
.string_length
;
3579 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
3580 expr
->expr_type
== EXPR_VARIABLE
, false);
3582 /* Form the mask expression according to the mask tree list. */
3585 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3587 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3588 TREE_TYPE (wheremaskexpr
),
3590 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3592 build_empty_stmt (input_location
));
3595 gfc_add_expr_to_block (&body1
, tmp
);
3597 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3598 count1
, gfc_index_one_node
);
3599 gfc_add_modify (&body1
, count1
, tmp
);
3601 if (lss
== gfc_ss_terminator
)
3602 gfc_add_block_to_block (&block
, &body1
);
3605 /* Increment count3. */
3608 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3609 gfc_array_index_type
,
3610 count3
, gfc_index_one_node
);
3611 gfc_add_modify (&body1
, count3
, tmp
);
3614 /* Generate the copying loops. */
3615 gfc_trans_scalarizing_loops (&loop
, &body1
);
3617 gfc_add_block_to_block (&block
, &loop
.pre
);
3618 gfc_add_block_to_block (&block
, &loop
.post
);
3620 gfc_cleanup_loop (&loop
);
3621 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3622 as tree nodes in SS may not be valid in different scope. */
3625 tmp
= gfc_finish_block (&block
);
3630 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3631 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3632 and should not be freed. WHEREMASK is the conditional execution mask
3633 whose sense may be inverted by INVERT. */
3636 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3637 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3638 tree wheremask
, bool invert
)
3640 stmtblock_t block
, body1
;
3647 gfc_start_block (&block
);
3649 gfc_init_se (&rse
, NULL
);
3650 gfc_init_se (&lse
, NULL
);
3652 if (lss
== gfc_ss_terminator
)
3654 gfc_init_block (&body1
);
3655 gfc_conv_expr (&rse
, expr2
);
3656 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3660 /* Initialize the loop. */
3661 gfc_init_loopinfo (&loop
);
3663 /* We may need LSS to determine the shape of the expression. */
3664 gfc_add_ss_to_loop (&loop
, lss
);
3665 gfc_add_ss_to_loop (&loop
, rss
);
3667 gfc_conv_ss_startstride (&loop
);
3668 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3670 gfc_mark_ss_chain_used (rss
, 1);
3671 /* Start the loop body. */
3672 gfc_start_scalarized_body (&loop
, &body1
);
3674 /* Translate the expression. */
3675 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3677 gfc_conv_expr (&rse
, expr2
);
3679 /* Form the expression of the temporary. */
3680 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3683 /* Use the scalar assignment. */
3684 lse
.string_length
= rse
.string_length
;
3685 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3686 expr2
->expr_type
== EXPR_VARIABLE
, false);
3688 /* Form the mask expression according to the mask tree list. */
3691 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3693 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3694 TREE_TYPE (wheremaskexpr
),
3696 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3698 build_empty_stmt (input_location
));
3701 gfc_add_expr_to_block (&body1
, tmp
);
3703 if (lss
== gfc_ss_terminator
)
3705 gfc_add_block_to_block (&block
, &body1
);
3707 /* Increment count1. */
3708 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3709 count1
, gfc_index_one_node
);
3710 gfc_add_modify (&block
, count1
, tmp
);
3714 /* Increment count1. */
3715 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3716 count1
, gfc_index_one_node
);
3717 gfc_add_modify (&body1
, count1
, tmp
);
3719 /* Increment count3. */
3722 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3723 gfc_array_index_type
,
3724 count3
, gfc_index_one_node
);
3725 gfc_add_modify (&body1
, count3
, tmp
);
3728 /* Generate the copying loops. */
3729 gfc_trans_scalarizing_loops (&loop
, &body1
);
3731 gfc_add_block_to_block (&block
, &loop
.pre
);
3732 gfc_add_block_to_block (&block
, &loop
.post
);
3734 gfc_cleanup_loop (&loop
);
3735 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3736 as tree nodes in SS may not be valid in different scope. */
3739 tmp
= gfc_finish_block (&block
);
3744 /* Calculate the size of temporary needed in the assignment inside forall.
3745 LSS and RSS are filled in this function. */
3748 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3749 stmtblock_t
* pblock
,
3750 gfc_ss
**lss
, gfc_ss
**rss
)
3758 *lss
= gfc_walk_expr (expr1
);
3761 size
= gfc_index_one_node
;
3762 if (*lss
!= gfc_ss_terminator
)
3764 gfc_init_loopinfo (&loop
);
3766 /* Walk the RHS of the expression. */
3767 *rss
= gfc_walk_expr (expr2
);
3768 if (*rss
== gfc_ss_terminator
)
3769 /* The rhs is scalar. Add a ss for the expression. */
3770 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3772 /* Associate the SS with the loop. */
3773 gfc_add_ss_to_loop (&loop
, *lss
);
3774 /* We don't actually need to add the rhs at this point, but it might
3775 make guessing the loop bounds a bit easier. */
3776 gfc_add_ss_to_loop (&loop
, *rss
);
3778 /* We only want the shape of the expression, not rest of the junk
3779 generated by the scalarizer. */
3780 loop
.array_parameter
= 1;
3782 /* Calculate the bounds of the scalarization. */
3783 save_flag
= gfc_option
.rtcheck
;
3784 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3785 gfc_conv_ss_startstride (&loop
);
3786 gfc_option
.rtcheck
= save_flag
;
3787 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3789 /* Figure out how many elements we need. */
3790 for (i
= 0; i
< loop
.dimen
; i
++)
3792 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3793 gfc_array_index_type
,
3794 gfc_index_one_node
, loop
.from
[i
]);
3795 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3796 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3797 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3798 gfc_array_index_type
, size
, tmp
);
3800 gfc_add_block_to_block (pblock
, &loop
.pre
);
3801 size
= gfc_evaluate_now (size
, pblock
);
3802 gfc_add_block_to_block (pblock
, &loop
.post
);
3804 /* TODO: write a function that cleans up a loopinfo without freeing
3805 the SS chains. Currently a NOP. */
3812 /* Calculate the overall iterator number of the nested forall construct.
3813 This routine actually calculates the number of times the body of the
3814 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3815 that by the expression INNER_SIZE. The BLOCK argument specifies the
3816 block in which to calculate the result, and the optional INNER_SIZE_BODY
3817 argument contains any statements that need to executed (inside the loop)
3818 to initialize or calculate INNER_SIZE. */
3821 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3822 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3824 forall_info
*forall_tmp
= nested_forall_info
;
3828 /* We can eliminate the innermost unconditional loops with constant
3830 if (INTEGER_CST_P (inner_size
))
3833 && !forall_tmp
->mask
3834 && INTEGER_CST_P (forall_tmp
->size
))
3836 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3837 gfc_array_index_type
,
3838 inner_size
, forall_tmp
->size
);
3839 forall_tmp
= forall_tmp
->prev_nest
;
3842 /* If there are no loops left, we have our constant result. */
3847 /* Otherwise, create a temporary variable to compute the result. */
3848 number
= gfc_create_var (gfc_array_index_type
, "num");
3849 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3851 gfc_start_block (&body
);
3852 if (inner_size_body
)
3853 gfc_add_block_to_block (&body
, inner_size_body
);
3855 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3856 gfc_array_index_type
, number
, inner_size
);
3859 gfc_add_modify (&body
, number
, tmp
);
3860 tmp
= gfc_finish_block (&body
);
3862 /* Generate loops. */
3863 if (forall_tmp
!= NULL
)
3864 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3866 gfc_add_expr_to_block (block
, tmp
);
3872 /* Allocate temporary for forall construct. SIZE is the size of temporary
3873 needed. PTEMP1 is returned for space free. */
3876 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3883 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3884 if (!integer_onep (unit
))
3885 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3886 gfc_array_index_type
, size
, unit
);
3891 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3894 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3899 /* Allocate temporary for forall construct according to the information in
3900 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3901 assignment inside forall. PTEMP1 is returned for space free. */
3904 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3905 tree inner_size
, stmtblock_t
* inner_size_body
,
3906 stmtblock_t
* block
, tree
* ptemp1
)
3910 /* Calculate the total size of temporary needed in forall construct. */
3911 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3912 inner_size_body
, block
);
3914 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3918 /* Handle assignments inside forall which need temporary.
3920 forall (i=start:end:stride; maskexpr)
3923 (where e,f<i> are arbitrary expressions possibly involving i
3924 and there is a dependency between e<i> and f<i>)
3926 masktmp(:) = maskexpr(:)
3931 for (i = start; i <= end; i += stride)
3935 for (i = start; i <= end; i += stride)
3937 if (masktmp[maskindex++])
3938 tmp[count1++] = f<i>
3942 for (i = start; i <= end; i += stride)
3944 if (masktmp[maskindex++])
3945 e<i> = tmp[count1++]
3950 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3951 tree wheremask
, bool invert
,
3952 forall_info
* nested_forall_info
,
3953 stmtblock_t
* block
)
3961 stmtblock_t inner_size_body
;
3963 /* Create vars. count1 is the current iterator number of the nested
3965 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3967 /* Count is the wheremask index. */
3970 count
= gfc_create_var (gfc_array_index_type
, "count");
3971 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3976 /* Initialize count1. */
3977 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3979 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3980 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3981 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3982 if (expr1
->ts
.type
== BT_CHARACTER
)
3985 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
3988 gfc_init_se (&ssse
, NULL
);
3989 gfc_conv_expr (&ssse
, expr1
);
3990 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3991 ssse
.string_length
);
3995 if (!expr1
->ts
.u
.cl
->backend_decl
)
3998 gcc_assert (expr1
->ts
.u
.cl
->length
);
3999 gfc_init_se (&tse
, NULL
);
4000 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4001 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4003 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4004 expr1
->ts
.u
.cl
->backend_decl
);
4008 type
= gfc_typenode_for_spec (&expr1
->ts
);
4010 gfc_init_block (&inner_size_body
);
4011 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4014 /* Allocate temporary for nested forall construct according to the
4015 information in nested_forall_info and inner_size. */
4016 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4017 &inner_size_body
, block
, &ptemp1
);
4019 /* Generate codes to copy rhs to the temporary . */
4020 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4023 /* Generate body and loops according to the information in
4024 nested_forall_info. */
4025 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4026 gfc_add_expr_to_block (block
, tmp
);
4029 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4033 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4035 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4036 rss; there must be a better way. */
4037 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4040 /* Generate codes to copy the temporary to lhs. */
4041 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4045 /* Generate body and loops according to the information in
4046 nested_forall_info. */
4047 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4048 gfc_add_expr_to_block (block
, tmp
);
4052 /* Free the temporary. */
4053 tmp
= gfc_call_free (ptemp1
);
4054 gfc_add_expr_to_block (block
, tmp
);
4059 /* Translate pointer assignment inside FORALL which need temporary. */
4062 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4063 forall_info
* nested_forall_info
,
4064 stmtblock_t
* block
)
4071 gfc_array_info
*info
;
4078 tree tmp
, tmp1
, ptemp1
;
4080 count
= gfc_create_var (gfc_array_index_type
, "count");
4081 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4083 inner_size
= gfc_index_one_node
;
4084 lss
= gfc_walk_expr (expr1
);
4085 rss
= gfc_walk_expr (expr2
);
4086 if (lss
== gfc_ss_terminator
)
4088 type
= gfc_typenode_for_spec (&expr1
->ts
);
4089 type
= build_pointer_type (type
);
4091 /* Allocate temporary for nested forall construct according to the
4092 information in nested_forall_info and inner_size. */
4093 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4094 inner_size
, NULL
, block
, &ptemp1
);
4095 gfc_start_block (&body
);
4096 gfc_init_se (&lse
, NULL
);
4097 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4098 gfc_init_se (&rse
, NULL
);
4099 rse
.want_pointer
= 1;
4100 gfc_conv_expr (&rse
, expr2
);
4101 gfc_add_block_to_block (&body
, &rse
.pre
);
4102 gfc_add_modify (&body
, lse
.expr
,
4103 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4104 gfc_add_block_to_block (&body
, &rse
.post
);
4106 /* Increment count. */
4107 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4108 count
, gfc_index_one_node
);
4109 gfc_add_modify (&body
, count
, tmp
);
4111 tmp
= gfc_finish_block (&body
);
4113 /* Generate body and loops according to the information in
4114 nested_forall_info. */
4115 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4116 gfc_add_expr_to_block (block
, tmp
);
4119 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4121 gfc_start_block (&body
);
4122 gfc_init_se (&lse
, NULL
);
4123 gfc_init_se (&rse
, NULL
);
4124 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4125 lse
.want_pointer
= 1;
4126 gfc_conv_expr (&lse
, expr1
);
4127 gfc_add_block_to_block (&body
, &lse
.pre
);
4128 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4129 gfc_add_block_to_block (&body
, &lse
.post
);
4130 /* Increment count. */
4131 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4132 count
, gfc_index_one_node
);
4133 gfc_add_modify (&body
, count
, tmp
);
4134 tmp
= gfc_finish_block (&body
);
4136 /* Generate body and loops according to the information in
4137 nested_forall_info. */
4138 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4139 gfc_add_expr_to_block (block
, tmp
);
4143 gfc_init_loopinfo (&loop
);
4145 /* Associate the SS with the loop. */
4146 gfc_add_ss_to_loop (&loop
, rss
);
4148 /* Setup the scalarizing loops and bounds. */
4149 gfc_conv_ss_startstride (&loop
);
4151 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4153 info
= &rss
->info
->data
.array
;
4154 desc
= info
->descriptor
;
4156 /* Make a new descriptor. */
4157 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4158 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4159 loop
.from
, loop
.to
, 1,
4160 GFC_ARRAY_UNKNOWN
, true);
4162 /* Allocate temporary for nested forall construct. */
4163 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4164 inner_size
, NULL
, block
, &ptemp1
);
4165 gfc_start_block (&body
);
4166 gfc_init_se (&lse
, NULL
);
4167 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4168 lse
.direct_byref
= 1;
4169 gfc_conv_expr_descriptor (&lse
, expr2
);
4171 gfc_add_block_to_block (&body
, &lse
.pre
);
4172 gfc_add_block_to_block (&body
, &lse
.post
);
4174 /* Increment count. */
4175 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4176 count
, gfc_index_one_node
);
4177 gfc_add_modify (&body
, count
, tmp
);
4179 tmp
= gfc_finish_block (&body
);
4181 /* Generate body and loops according to the information in
4182 nested_forall_info. */
4183 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4184 gfc_add_expr_to_block (block
, tmp
);
4187 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4189 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4190 gfc_init_se (&lse
, NULL
);
4191 gfc_conv_expr_descriptor (&lse
, expr1
);
4192 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4193 gfc_start_block (&body
);
4194 gfc_add_block_to_block (&body
, &lse
.pre
);
4195 gfc_add_block_to_block (&body
, &lse
.post
);
4197 /* Increment count. */
4198 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4199 count
, gfc_index_one_node
);
4200 gfc_add_modify (&body
, count
, tmp
);
4202 tmp
= gfc_finish_block (&body
);
4204 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4205 gfc_add_expr_to_block (block
, tmp
);
4207 /* Free the temporary. */
4210 tmp
= gfc_call_free (ptemp1
);
4211 gfc_add_expr_to_block (block
, tmp
);
4216 /* FORALL and WHERE statements are really nasty, especially when you nest
4217 them. All the rhs of a forall assignment must be evaluated before the
4218 actual assignments are performed. Presumably this also applies to all the
4219 assignments in an inner where statement. */
4221 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4222 linear array, relying on the fact that we process in the same order in all
4225 forall (i=start:end:stride; maskexpr)
4229 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4231 count = ((end + 1 - start) / stride)
4232 masktmp(:) = maskexpr(:)
4235 for (i = start; i <= end; i += stride)
4237 if (masktmp[maskindex++])
4241 for (i = start; i <= end; i += stride)
4243 if (masktmp[maskindex++])
4247 Note that this code only works when there are no dependencies.
4248 Forall loop with array assignments and data dependencies are a real pain,
4249 because the size of the temporary cannot always be determined before the
4250 loop is executed. This problem is compounded by the presence of nested
4255 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4272 tree cycle_label
= NULL_TREE
;
4276 gfc_forall_iterator
*fa
;
4279 gfc_saved_var
*saved_vars
;
4280 iter_info
*this_forall
;
4284 /* Do nothing if the mask is false. */
4286 && code
->expr1
->expr_type
== EXPR_CONSTANT
4287 && !code
->expr1
->value
.logical
)
4288 return build_empty_stmt (input_location
);
4291 /* Count the FORALL index number. */
4292 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4296 /* Allocate the space for var, start, end, step, varexpr. */
4297 var
= XCNEWVEC (tree
, nvar
);
4298 start
= XCNEWVEC (tree
, nvar
);
4299 end
= XCNEWVEC (tree
, nvar
);
4300 step
= XCNEWVEC (tree
, nvar
);
4301 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4302 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4304 /* Allocate the space for info. */
4305 info
= XCNEW (forall_info
);
4307 gfc_start_block (&pre
);
4308 gfc_init_block (&post
);
4309 gfc_init_block (&block
);
4312 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4314 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4316 /* Allocate space for this_forall. */
4317 this_forall
= XCNEW (iter_info
);
4319 /* Create a temporary variable for the FORALL index. */
4320 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4321 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4322 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4324 /* Record it in this_forall. */
4325 this_forall
->var
= var
[n
];
4327 /* Replace the index symbol's backend_decl with the temporary decl. */
4328 sym
->backend_decl
= var
[n
];
4330 /* Work out the start, end and stride for the loop. */
4331 gfc_init_se (&se
, NULL
);
4332 gfc_conv_expr_val (&se
, fa
->start
);
4333 /* Record it in this_forall. */
4334 this_forall
->start
= se
.expr
;
4335 gfc_add_block_to_block (&block
, &se
.pre
);
4338 gfc_init_se (&se
, NULL
);
4339 gfc_conv_expr_val (&se
, fa
->end
);
4340 /* Record it in this_forall. */
4341 this_forall
->end
= se
.expr
;
4342 gfc_make_safe_expr (&se
);
4343 gfc_add_block_to_block (&block
, &se
.pre
);
4346 gfc_init_se (&se
, NULL
);
4347 gfc_conv_expr_val (&se
, fa
->stride
);
4348 /* Record it in this_forall. */
4349 this_forall
->step
= se
.expr
;
4350 gfc_make_safe_expr (&se
);
4351 gfc_add_block_to_block (&block
, &se
.pre
);
4354 /* Set the NEXT field of this_forall to NULL. */
4355 this_forall
->next
= NULL
;
4356 /* Link this_forall to the info construct. */
4357 if (info
->this_loop
)
4359 iter_info
*iter_tmp
= info
->this_loop
;
4360 while (iter_tmp
->next
!= NULL
)
4361 iter_tmp
= iter_tmp
->next
;
4362 iter_tmp
->next
= this_forall
;
4365 info
->this_loop
= this_forall
;
4371 /* Calculate the size needed for the current forall level. */
4372 size
= gfc_index_one_node
;
4373 for (n
= 0; n
< nvar
; n
++)
4375 /* size = (end + step - start) / step. */
4376 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4378 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4380 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4382 tmp
= convert (gfc_array_index_type
, tmp
);
4384 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4388 /* Record the nvar and size of current forall level. */
4394 /* If the mask is .true., consider the FORALL unconditional. */
4395 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4396 && code
->expr1
->value
.logical
)
4404 /* First we need to allocate the mask. */
4407 /* As the mask array can be very big, prefer compact boolean types. */
4408 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4409 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4410 size
, NULL
, &block
, &pmask
);
4411 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4413 /* Record them in the info structure. */
4414 info
->maskindex
= maskindex
;
4419 /* No mask was specified. */
4420 maskindex
= NULL_TREE
;
4421 mask
= pmask
= NULL_TREE
;
4424 /* Link the current forall level to nested_forall_info. */
4425 info
->prev_nest
= nested_forall_info
;
4426 nested_forall_info
= info
;
4428 /* Copy the mask into a temporary variable if required.
4429 For now we assume a mask temporary is needed. */
4432 /* As the mask array can be very big, prefer compact boolean types. */
4433 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4435 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4437 /* Start of mask assignment loop body. */
4438 gfc_start_block (&body
);
4440 /* Evaluate the mask expression. */
4441 gfc_init_se (&se
, NULL
);
4442 gfc_conv_expr_val (&se
, code
->expr1
);
4443 gfc_add_block_to_block (&body
, &se
.pre
);
4445 /* Store the mask. */
4446 se
.expr
= convert (mask_type
, se
.expr
);
4448 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4449 gfc_add_modify (&body
, tmp
, se
.expr
);
4451 /* Advance to the next mask element. */
4452 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4453 maskindex
, gfc_index_one_node
);
4454 gfc_add_modify (&body
, maskindex
, tmp
);
4456 /* Generate the loops. */
4457 tmp
= gfc_finish_block (&body
);
4458 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4459 gfc_add_expr_to_block (&block
, tmp
);
4462 if (code
->op
== EXEC_DO_CONCURRENT
)
4464 gfc_init_block (&body
);
4465 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4466 code
->cycle_label
= cycle_label
;
4467 tmp
= gfc_trans_code (code
->block
->next
);
4468 gfc_add_expr_to_block (&body
, tmp
);
4470 if (TREE_USED (cycle_label
))
4472 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4473 gfc_add_expr_to_block (&body
, tmp
);
4476 tmp
= gfc_finish_block (&body
);
4477 nested_forall_info
->do_concurrent
= true;
4478 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4479 gfc_add_expr_to_block (&block
, tmp
);
4483 c
= code
->block
->next
;
4485 /* TODO: loop merging in FORALL statements. */
4486 /* Now that we've got a copy of the mask, generate the assignment loops. */
4492 /* A scalar or array assignment. DO the simple check for
4493 lhs to rhs dependencies. These make a temporary for the
4494 rhs and form a second forall block to copy to variable. */
4495 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4497 /* Temporaries due to array assignment data dependencies introduce
4498 no end of problems. */
4499 if (need_temp
|| flag_test_forall_temp
)
4500 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4501 nested_forall_info
, &block
);
4504 /* Use the normal assignment copying routines. */
4505 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4507 /* Generate body and loops. */
4508 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4510 gfc_add_expr_to_block (&block
, tmp
);
4513 /* Cleanup any temporary symtrees that have been made to deal
4514 with dependencies. */
4516 cleanup_forall_symtrees (c
);
4521 /* Translate WHERE or WHERE construct nested in FORALL. */
4522 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4525 /* Pointer assignment inside FORALL. */
4526 case EXEC_POINTER_ASSIGN
:
4527 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4528 /* Avoid cases where a temporary would never be needed and where
4529 the temp code is guaranteed to fail. */
4531 || (flag_test_forall_temp
4532 && c
->expr2
->expr_type
!= EXPR_CONSTANT
4533 && c
->expr2
->expr_type
!= EXPR_NULL
))
4534 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4535 nested_forall_info
, &block
);
4538 /* Use the normal assignment copying routines. */
4539 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4541 /* Generate body and loops. */
4542 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4544 gfc_add_expr_to_block (&block
, tmp
);
4549 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4550 gfc_add_expr_to_block (&block
, tmp
);
4553 /* Explicit subroutine calls are prevented by the frontend but interface
4554 assignments can legitimately produce them. */
4555 case EXEC_ASSIGN_CALL
:
4556 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4557 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4558 gfc_add_expr_to_block (&block
, tmp
);
4569 /* Restore the original index variables. */
4570 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4571 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4573 /* Free the space for var, start, end, step, varexpr. */
4581 for (this_forall
= info
->this_loop
; this_forall
;)
4583 iter_info
*next
= this_forall
->next
;
4588 /* Free the space for this forall_info. */
4593 /* Free the temporary for the mask. */
4594 tmp
= gfc_call_free (pmask
);
4595 gfc_add_expr_to_block (&block
, tmp
);
4598 pushdecl (maskindex
);
4600 gfc_add_block_to_block (&pre
, &block
);
4601 gfc_add_block_to_block (&pre
, &post
);
4603 return gfc_finish_block (&pre
);
4607 /* Translate the FORALL statement or construct. */
4609 tree
gfc_trans_forall (gfc_code
* code
)
4611 return gfc_trans_forall_1 (code
, NULL
);
4615 /* Translate the DO CONCURRENT construct. */
4617 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4619 return gfc_trans_forall_1 (code
, NULL
);
4623 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4624 If the WHERE construct is nested in FORALL, compute the overall temporary
4625 needed by the WHERE mask expression multiplied by the iterator number of
4627 ME is the WHERE mask expression.
4628 MASK is the current execution mask upon input, whose sense may or may
4629 not be inverted as specified by the INVERT argument.
4630 CMASK is the updated execution mask on output, or NULL if not required.
4631 PMASK is the pending execution mask on output, or NULL if not required.
4632 BLOCK is the block in which to place the condition evaluation loops. */
4635 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4636 tree mask
, bool invert
, tree cmask
, tree pmask
,
4637 tree mask_type
, stmtblock_t
* block
)
4642 stmtblock_t body
, body1
;
4643 tree count
, cond
, mtmp
;
4646 gfc_init_loopinfo (&loop
);
4648 lss
= gfc_walk_expr (me
);
4649 rss
= gfc_walk_expr (me
);
4651 /* Variable to index the temporary. */
4652 count
= gfc_create_var (gfc_array_index_type
, "count");
4653 /* Initialize count. */
4654 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4656 gfc_start_block (&body
);
4658 gfc_init_se (&rse
, NULL
);
4659 gfc_init_se (&lse
, NULL
);
4661 if (lss
== gfc_ss_terminator
)
4663 gfc_init_block (&body1
);
4667 /* Initialize the loop. */
4668 gfc_init_loopinfo (&loop
);
4670 /* We may need LSS to determine the shape of the expression. */
4671 gfc_add_ss_to_loop (&loop
, lss
);
4672 gfc_add_ss_to_loop (&loop
, rss
);
4674 gfc_conv_ss_startstride (&loop
);
4675 gfc_conv_loop_setup (&loop
, &me
->where
);
4677 gfc_mark_ss_chain_used (rss
, 1);
4678 /* Start the loop body. */
4679 gfc_start_scalarized_body (&loop
, &body1
);
4681 /* Translate the expression. */
4682 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4684 gfc_conv_expr (&rse
, me
);
4687 /* Variable to evaluate mask condition. */
4688 cond
= gfc_create_var (mask_type
, "cond");
4689 if (mask
&& (cmask
|| pmask
))
4690 mtmp
= gfc_create_var (mask_type
, "mask");
4691 else mtmp
= NULL_TREE
;
4693 gfc_add_block_to_block (&body1
, &lse
.pre
);
4694 gfc_add_block_to_block (&body1
, &rse
.pre
);
4696 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4698 if (mask
&& (cmask
|| pmask
))
4700 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4702 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4703 gfc_add_modify (&body1
, mtmp
, tmp
);
4708 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4711 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4713 gfc_add_modify (&body1
, tmp1
, tmp
);
4718 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4719 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4721 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4723 gfc_add_modify (&body1
, tmp1
, tmp
);
4726 gfc_add_block_to_block (&body1
, &lse
.post
);
4727 gfc_add_block_to_block (&body1
, &rse
.post
);
4729 if (lss
== gfc_ss_terminator
)
4731 gfc_add_block_to_block (&body
, &body1
);
4735 /* Increment count. */
4736 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4737 count
, gfc_index_one_node
);
4738 gfc_add_modify (&body1
, count
, tmp1
);
4740 /* Generate the copying loops. */
4741 gfc_trans_scalarizing_loops (&loop
, &body1
);
4743 gfc_add_block_to_block (&body
, &loop
.pre
);
4744 gfc_add_block_to_block (&body
, &loop
.post
);
4746 gfc_cleanup_loop (&loop
);
4747 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4748 as tree nodes in SS may not be valid in different scope. */
4751 tmp1
= gfc_finish_block (&body
);
4752 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4753 if (nested_forall_info
!= NULL
)
4754 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4756 gfc_add_expr_to_block (block
, tmp1
);
4760 /* Translate an assignment statement in a WHERE statement or construct
4761 statement. The MASK expression is used to control which elements
4762 of EXPR1 shall be assigned. The sense of MASK is specified by
4766 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4767 tree mask
, bool invert
,
4768 tree count1
, tree count2
,
4774 gfc_ss
*lss_section
;
4781 tree index
, maskexpr
;
4783 /* A defined assignment. */
4784 if (cnext
&& cnext
->resolved_sym
)
4785 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4788 /* TODO: handle this special case.
4789 Special case a single function returning an array. */
4790 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4792 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4798 /* Assignment of the form lhs = rhs. */
4799 gfc_start_block (&block
);
4801 gfc_init_se (&lse
, NULL
);
4802 gfc_init_se (&rse
, NULL
);
4805 lss
= gfc_walk_expr (expr1
);
4808 /* In each where-assign-stmt, the mask-expr and the variable being
4809 defined shall be arrays of the same shape. */
4810 gcc_assert (lss
!= gfc_ss_terminator
);
4812 /* The assignment needs scalarization. */
4815 /* Find a non-scalar SS from the lhs. */
4816 while (lss_section
!= gfc_ss_terminator
4817 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4818 lss_section
= lss_section
->next
;
4820 gcc_assert (lss_section
!= gfc_ss_terminator
);
4822 /* Initialize the scalarizer. */
4823 gfc_init_loopinfo (&loop
);
4826 rss
= gfc_walk_expr (expr2
);
4827 if (rss
== gfc_ss_terminator
)
4829 /* The rhs is scalar. Add a ss for the expression. */
4830 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4831 rss
->info
->where
= 1;
4834 /* Associate the SS with the loop. */
4835 gfc_add_ss_to_loop (&loop
, lss
);
4836 gfc_add_ss_to_loop (&loop
, rss
);
4838 /* Calculate the bounds of the scalarization. */
4839 gfc_conv_ss_startstride (&loop
);
4841 /* Resolve any data dependencies in the statement. */
4842 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4844 /* Setup the scalarizing loops. */
4845 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4847 /* Setup the gfc_se structures. */
4848 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4849 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4852 gfc_mark_ss_chain_used (rss
, 1);
4853 if (loop
.temp_ss
== NULL
)
4856 gfc_mark_ss_chain_used (lss
, 1);
4860 lse
.ss
= loop
.temp_ss
;
4861 gfc_mark_ss_chain_used (lss
, 3);
4862 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4865 /* Start the scalarized loop body. */
4866 gfc_start_scalarized_body (&loop
, &body
);
4868 /* Translate the expression. */
4869 gfc_conv_expr (&rse
, expr2
);
4870 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4871 gfc_conv_tmp_array_ref (&lse
);
4873 gfc_conv_expr (&lse
, expr1
);
4875 /* Form the mask expression according to the mask. */
4877 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4879 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4880 TREE_TYPE (maskexpr
), maskexpr
);
4882 /* Use the scalar assignment as is. */
4883 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4884 false, loop
.temp_ss
== NULL
);
4886 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4888 gfc_add_expr_to_block (&body
, tmp
);
4890 if (lss
== gfc_ss_terminator
)
4892 /* Increment count1. */
4893 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4894 count1
, gfc_index_one_node
);
4895 gfc_add_modify (&body
, count1
, tmp
);
4897 /* Use the scalar assignment as is. */
4898 gfc_add_block_to_block (&block
, &body
);
4902 gcc_assert (lse
.ss
== gfc_ss_terminator
4903 && rse
.ss
== gfc_ss_terminator
);
4905 if (loop
.temp_ss
!= NULL
)
4907 /* Increment count1 before finish the main body of a scalarized
4909 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4910 gfc_array_index_type
, count1
, gfc_index_one_node
);
4911 gfc_add_modify (&body
, count1
, tmp
);
4912 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4914 /* We need to copy the temporary to the actual lhs. */
4915 gfc_init_se (&lse
, NULL
);
4916 gfc_init_se (&rse
, NULL
);
4917 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4918 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4920 rse
.ss
= loop
.temp_ss
;
4923 gfc_conv_tmp_array_ref (&rse
);
4924 gfc_conv_expr (&lse
, expr1
);
4926 gcc_assert (lse
.ss
== gfc_ss_terminator
4927 && rse
.ss
== gfc_ss_terminator
);
4929 /* Form the mask expression according to the mask tree list. */
4931 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4933 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4934 TREE_TYPE (maskexpr
), maskexpr
);
4936 /* Use the scalar assignment as is. */
4937 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
4938 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
4939 build_empty_stmt (input_location
));
4940 gfc_add_expr_to_block (&body
, tmp
);
4942 /* Increment count2. */
4943 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4944 gfc_array_index_type
, count2
,
4945 gfc_index_one_node
);
4946 gfc_add_modify (&body
, count2
, tmp
);
4950 /* Increment count1. */
4951 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4952 gfc_array_index_type
, count1
,
4953 gfc_index_one_node
);
4954 gfc_add_modify (&body
, count1
, tmp
);
4957 /* Generate the copying loops. */
4958 gfc_trans_scalarizing_loops (&loop
, &body
);
4960 /* Wrap the whole thing up. */
4961 gfc_add_block_to_block (&block
, &loop
.pre
);
4962 gfc_add_block_to_block (&block
, &loop
.post
);
4963 gfc_cleanup_loop (&loop
);
4966 return gfc_finish_block (&block
);
4970 /* Translate the WHERE construct or statement.
4971 This function can be called iteratively to translate the nested WHERE
4972 construct or statement.
4973 MASK is the control mask. */
4976 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
4977 forall_info
* nested_forall_info
, stmtblock_t
* block
)
4979 stmtblock_t inner_size_body
;
4980 tree inner_size
, size
;
4989 tree count1
, count2
;
4993 tree pcmask
= NULL_TREE
;
4994 tree ppmask
= NULL_TREE
;
4995 tree cmask
= NULL_TREE
;
4996 tree pmask
= NULL_TREE
;
4997 gfc_actual_arglist
*arg
;
4999 /* the WHERE statement or the WHERE construct statement. */
5000 cblock
= code
->block
;
5002 /* As the mask array can be very big, prefer compact boolean types. */
5003 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5005 /* Determine which temporary masks are needed. */
5008 /* One clause: No ELSEWHEREs. */
5009 need_cmask
= (cblock
->next
!= 0);
5012 else if (cblock
->block
->block
)
5014 /* Three or more clauses: Conditional ELSEWHEREs. */
5018 else if (cblock
->next
)
5020 /* Two clauses, the first non-empty. */
5022 need_pmask
= (mask
!= NULL_TREE
5023 && cblock
->block
->next
!= 0);
5025 else if (!cblock
->block
->next
)
5027 /* Two clauses, both empty. */
5031 /* Two clauses, the first empty, the second non-empty. */
5034 need_cmask
= (cblock
->block
->expr1
!= 0);
5043 if (need_cmask
|| need_pmask
)
5045 /* Calculate the size of temporary needed by the mask-expr. */
5046 gfc_init_block (&inner_size_body
);
5047 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5048 &inner_size_body
, &lss
, &rss
);
5050 gfc_free_ss_chain (lss
);
5051 gfc_free_ss_chain (rss
);
5053 /* Calculate the total size of temporary needed. */
5054 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5055 &inner_size_body
, block
);
5057 /* Check whether the size is negative. */
5058 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
5059 gfc_index_zero_node
);
5060 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5061 cond
, gfc_index_zero_node
, size
);
5062 size
= gfc_evaluate_now (size
, block
);
5064 /* Allocate temporary for WHERE mask if needed. */
5066 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5069 /* Allocate temporary for !mask if needed. */
5071 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5077 /* Each time around this loop, the where clause is conditional
5078 on the value of mask and invert, which are updated at the
5079 bottom of the loop. */
5081 /* Has mask-expr. */
5084 /* Ensure that the WHERE mask will be evaluated exactly once.
5085 If there are no statements in this WHERE/ELSEWHERE clause,
5086 then we don't need to update the control mask (cmask).
5087 If this is the last clause of the WHERE construct, then
5088 we don't need to update the pending control mask (pmask). */
5090 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5092 cblock
->next
? cmask
: NULL_TREE
,
5093 cblock
->block
? pmask
: NULL_TREE
,
5096 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5098 (cblock
->next
|| cblock
->block
)
5099 ? cmask
: NULL_TREE
,
5100 NULL_TREE
, mask_type
, block
);
5104 /* It's a final elsewhere-stmt. No mask-expr is present. */
5108 /* The body of this where clause are controlled by cmask with
5109 sense specified by invert. */
5111 /* Get the assignment statement of a WHERE statement, or the first
5112 statement in where-body-construct of a WHERE construct. */
5113 cnext
= cblock
->next
;
5118 /* WHERE assignment statement. */
5119 case EXEC_ASSIGN_CALL
:
5121 arg
= cnext
->ext
.actual
;
5122 expr1
= expr2
= NULL
;
5123 for (; arg
; arg
= arg
->next
)
5135 expr1
= cnext
->expr1
;
5136 expr2
= cnext
->expr2
;
5138 if (nested_forall_info
!= NULL
)
5140 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5141 if ((need_temp
|| flag_test_forall_temp
)
5142 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5143 gfc_trans_assign_need_temp (expr1
, expr2
,
5145 nested_forall_info
, block
);
5148 /* Variables to control maskexpr. */
5149 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5150 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5151 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5152 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5154 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5159 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5161 gfc_add_expr_to_block (block
, tmp
);
5166 /* Variables to control maskexpr. */
5167 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5168 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5169 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5170 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5172 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5176 gfc_add_expr_to_block (block
, tmp
);
5181 /* WHERE or WHERE construct is part of a where-body-construct. */
5183 gfc_trans_where_2 (cnext
, cmask
, invert
,
5184 nested_forall_info
, block
);
5191 /* The next statement within the same where-body-construct. */
5192 cnext
= cnext
->next
;
5194 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5195 cblock
= cblock
->block
;
5196 if (mask
== NULL_TREE
)
5198 /* If we're the initial WHERE, we can simply invert the sense
5199 of the current mask to obtain the "mask" for the remaining
5206 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5212 /* If we allocated a pending mask array, deallocate it now. */
5215 tmp
= gfc_call_free (ppmask
);
5216 gfc_add_expr_to_block (block
, tmp
);
5219 /* If we allocated a current mask array, deallocate it now. */
5222 tmp
= gfc_call_free (pcmask
);
5223 gfc_add_expr_to_block (block
, tmp
);
5227 /* Translate a simple WHERE construct or statement without dependencies.
5228 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5229 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5230 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5233 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5235 stmtblock_t block
, body
;
5236 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5237 tree tmp
, cexpr
, tstmt
, estmt
;
5238 gfc_ss
*css
, *tdss
, *tsss
;
5239 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5243 bool maybe_workshare
= false;
5245 /* Allow the scalarizer to workshare simple where loops. */
5246 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5247 == OMPWS_WORKSHARE_FLAG
)
5249 maybe_workshare
= true;
5250 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5253 cond
= cblock
->expr1
;
5254 tdst
= cblock
->next
->expr1
;
5255 tsrc
= cblock
->next
->expr2
;
5256 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5257 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5259 gfc_start_block (&block
);
5260 gfc_init_loopinfo (&loop
);
5262 /* Handle the condition. */
5263 gfc_init_se (&cse
, NULL
);
5264 css
= gfc_walk_expr (cond
);
5265 gfc_add_ss_to_loop (&loop
, css
);
5267 /* Handle the then-clause. */
5268 gfc_init_se (&tdse
, NULL
);
5269 gfc_init_se (&tsse
, NULL
);
5270 tdss
= gfc_walk_expr (tdst
);
5271 tsss
= gfc_walk_expr (tsrc
);
5272 if (tsss
== gfc_ss_terminator
)
5274 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5275 tsss
->info
->where
= 1;
5277 gfc_add_ss_to_loop (&loop
, tdss
);
5278 gfc_add_ss_to_loop (&loop
, tsss
);
5282 /* Handle the else clause. */
5283 gfc_init_se (&edse
, NULL
);
5284 gfc_init_se (&esse
, NULL
);
5285 edss
= gfc_walk_expr (edst
);
5286 esss
= gfc_walk_expr (esrc
);
5287 if (esss
== gfc_ss_terminator
)
5289 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5290 esss
->info
->where
= 1;
5292 gfc_add_ss_to_loop (&loop
, edss
);
5293 gfc_add_ss_to_loop (&loop
, esss
);
5296 gfc_conv_ss_startstride (&loop
);
5297 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5299 gfc_mark_ss_chain_used (css
, 1);
5300 gfc_mark_ss_chain_used (tdss
, 1);
5301 gfc_mark_ss_chain_used (tsss
, 1);
5304 gfc_mark_ss_chain_used (edss
, 1);
5305 gfc_mark_ss_chain_used (esss
, 1);
5308 gfc_start_scalarized_body (&loop
, &body
);
5310 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5311 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5312 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5318 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5319 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5324 gfc_conv_expr (&cse
, cond
);
5325 gfc_add_block_to_block (&body
, &cse
.pre
);
5328 gfc_conv_expr (&tsse
, tsrc
);
5329 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5330 gfc_conv_tmp_array_ref (&tdse
);
5332 gfc_conv_expr (&tdse
, tdst
);
5336 gfc_conv_expr (&esse
, esrc
);
5337 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5338 gfc_conv_tmp_array_ref (&edse
);
5340 gfc_conv_expr (&edse
, edst
);
5343 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5344 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5346 : build_empty_stmt (input_location
);
5347 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5348 gfc_add_expr_to_block (&body
, tmp
);
5349 gfc_add_block_to_block (&body
, &cse
.post
);
5351 if (maybe_workshare
)
5352 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5353 gfc_trans_scalarizing_loops (&loop
, &body
);
5354 gfc_add_block_to_block (&block
, &loop
.pre
);
5355 gfc_add_block_to_block (&block
, &loop
.post
);
5356 gfc_cleanup_loop (&loop
);
5358 return gfc_finish_block (&block
);
5361 /* As the WHERE or WHERE construct statement can be nested, we call
5362 gfc_trans_where_2 to do the translation, and pass the initial
5363 NULL values for both the control mask and the pending control mask. */
5366 gfc_trans_where (gfc_code
* code
)
5372 cblock
= code
->block
;
5374 && cblock
->next
->op
== EXEC_ASSIGN
5375 && !cblock
->next
->next
)
5377 eblock
= cblock
->block
;
5380 /* A simple "WHERE (cond) x = y" statement or block is
5381 dependence free if cond is not dependent upon writing x,
5382 and the source y is unaffected by the destination x. */
5383 if (!gfc_check_dependency (cblock
->next
->expr1
,
5385 && !gfc_check_dependency (cblock
->next
->expr1
,
5386 cblock
->next
->expr2
, 0))
5387 return gfc_trans_where_3 (cblock
, NULL
);
5389 else if (!eblock
->expr1
5392 && eblock
->next
->op
== EXEC_ASSIGN
5393 && !eblock
->next
->next
)
5395 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5396 block is dependence free if cond is not dependent on writes
5397 to x1 and x2, y1 is not dependent on writes to x2, and y2
5398 is not dependent on writes to x1, and both y's are not
5399 dependent upon their own x's. In addition to this, the
5400 final two dependency checks below exclude all but the same
5401 array reference if the where and elswhere destinations
5402 are the same. In short, this is VERY conservative and this
5403 is needed because the two loops, required by the standard
5404 are coalesced in gfc_trans_where_3. */
5405 if (!gfc_check_dependency (cblock
->next
->expr1
,
5407 && !gfc_check_dependency (eblock
->next
->expr1
,
5409 && !gfc_check_dependency (cblock
->next
->expr1
,
5410 eblock
->next
->expr2
, 1)
5411 && !gfc_check_dependency (eblock
->next
->expr1
,
5412 cblock
->next
->expr2
, 1)
5413 && !gfc_check_dependency (cblock
->next
->expr1
,
5414 cblock
->next
->expr2
, 1)
5415 && !gfc_check_dependency (eblock
->next
->expr1
,
5416 eblock
->next
->expr2
, 1)
5417 && !gfc_check_dependency (cblock
->next
->expr1
,
5418 eblock
->next
->expr1
, 0)
5419 && !gfc_check_dependency (eblock
->next
->expr1
,
5420 cblock
->next
->expr1
, 0))
5421 return gfc_trans_where_3 (cblock
, eblock
);
5425 gfc_start_block (&block
);
5427 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5429 return gfc_finish_block (&block
);
5433 /* CYCLE a DO loop. The label decl has already been created by
5434 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5435 node at the head of the loop. We must mark the label as used. */
5438 gfc_trans_cycle (gfc_code
* code
)
5442 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5443 gcc_assert (cycle_label
);
5445 TREE_USED (cycle_label
) = 1;
5446 return build1_v (GOTO_EXPR
, cycle_label
);
5450 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5451 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5455 gfc_trans_exit (gfc_code
* code
)
5459 exit_label
= code
->ext
.which_construct
->exit_label
;
5460 gcc_assert (exit_label
);
5462 TREE_USED (exit_label
) = 1;
5463 return build1_v (GOTO_EXPR
, exit_label
);
5467 /* Get the initializer expression for the code and expr of an allocate.
5468 When no initializer is needed return NULL. */
5471 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
5473 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
5476 /* An explicit type was given in allocate ( T:: object). */
5477 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
5478 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
5479 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
5480 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
5482 if (gfc_bt_struct (expr
->ts
.type
)
5483 && (expr
->ts
.u
.derived
->attr
.alloc_comp
5484 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
5485 return gfc_default_initializer (&expr
->ts
);
5487 if (expr
->ts
.type
== BT_CLASS
5488 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
5489 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
5490 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
5495 /* Translate the ALLOCATE statement. */
5498 gfc_trans_allocate (gfc_code
* code
)
5501 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
5511 tree al_vptr
, al_len
;
5512 /* If an expr3 is present, then store the tree for accessing its
5513 _vptr, and _len components in the variables, respectively. The
5514 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5515 the trees may be the NULL_TREE indicating that this is not
5516 available for expr3's type. */
5517 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5518 /* Classify what expr3 stores. */
5519 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5523 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
5524 bool needs_caf_sync
, caf_refs_comp
;
5525 gfc_symtree
*newsym
= NULL
;
5526 symbol_attribute caf_attr
;
5528 if (!code
->ext
.alloc
.list
)
5531 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5532 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5533 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5535 is_coarray
= needs_caf_sync
= false;
5537 gfc_init_block (&block
);
5538 gfc_init_block (&post
);
5540 /* STAT= (and maybe ERRMSG=) is present. */
5544 tree gfc_int4_type_node
= gfc_get_int_type (4);
5545 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5547 /* ERRMSG= only makes sense with STAT=. */
5550 gfc_init_se (&se
, NULL
);
5551 se
.want_pointer
= 1;
5552 gfc_conv_expr_lhs (&se
, code
->expr2
);
5554 errlen
= se
.string_length
;
5558 errmsg
= null_pointer_node
;
5559 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5562 /* GOTO destinations. */
5563 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5564 label_finish
= gfc_build_label_decl (NULL_TREE
);
5565 TREE_USED (label_finish
) = 0;
5568 /* When an expr3 is present evaluate it only once. The standards prevent a
5569 dependency of expr3 on the objects in the allocate list. An expr3 can
5570 be pre-evaluated in all cases. One just has to make sure, to use the
5571 correct way, i.e., to get the descriptor or to get a reference
5575 bool vtab_needed
= false, temp_var_needed
= false,
5576 temp_obj_created
= false;
5578 is_coarray
= gfc_is_coarray (code
->expr3
);
5580 /* Figure whether we need the vtab from expr3. */
5581 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5583 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5585 gfc_init_se (&se
, NULL
);
5586 /* When expr3 is a variable, i.e., a very simple expression,
5587 then convert it once here. */
5588 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5589 || code
->expr3
->expr_type
== EXPR_ARRAY
5590 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5592 if (!code
->expr3
->mold
5593 || code
->expr3
->ts
.type
== BT_CHARACTER
5595 || code
->ext
.alloc
.arr_spec_from_expr3
)
5597 /* Convert expr3 to a tree. For all "simple" expression just
5598 get the descriptor or the reference, respectively, depending
5599 on the rank of the expr. */
5600 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5601 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5604 gfc_conv_expr_reference (&se
, code
->expr3
);
5606 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5607 NOP_EXPR, which prevents gfortran from getting the vptr
5608 from the source=-expression. Remove the NOP_EXPR and go
5609 with the POINTER_PLUS_EXPR in this case. */
5610 if (code
->expr3
->ts
.type
== BT_CLASS
5611 && TREE_CODE (se
.expr
) == NOP_EXPR
5612 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5613 == POINTER_PLUS_EXPR
5615 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5617 /* Create a temp variable only for component refs to prevent
5618 having to go through the full deref-chain each time and to
5619 simplfy computation of array properties. */
5620 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5625 /* In all other cases evaluate the expr3. */
5626 symbol_attribute attr
;
5627 /* Get the descriptor for all arrays, that are not allocatable or
5628 pointer, because the latter are descriptors already.
5629 The exception are function calls returning a class object:
5630 The descriptor is stored in their results _data component, which
5631 is easier to access, when first a temporary variable for the
5632 result is created and the descriptor retrieved from there. */
5633 attr
= gfc_expr_attr (code
->expr3
);
5634 if (code
->expr3
->rank
!= 0
5635 && ((!attr
.allocatable
&& !attr
.pointer
)
5636 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5637 && (code
->expr3
->ts
.type
!= BT_CLASS
5638 || (code
->expr3
->value
.function
.isym
5639 && code
->expr3
->value
.function
.isym
5640 ->transformational
)))))
5641 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5643 gfc_conv_expr_reference (&se
, code
->expr3
);
5644 if (code
->expr3
->ts
.type
== BT_CLASS
)
5645 gfc_conv_class_to_class (&se
, code
->expr3
,
5649 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
5651 gfc_add_block_to_block (&block
, &se
.pre
);
5652 gfc_add_block_to_block (&post
, &se
.post
);
5654 /* Special case when string in expr3 is zero. */
5655 if (code
->expr3
->ts
.type
== BT_CHARACTER
5656 && integer_zerop (se
.string_length
))
5658 gfc_init_se (&se
, NULL
);
5659 temp_var_needed
= false;
5660 expr3_len
= integer_zero_node
;
5663 /* Prevent aliasing, i.e., se.expr may be already a
5664 variable declaration. */
5665 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5668 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5670 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5672 /* Get the array descriptor and prepare it to be assigned to the
5673 temporary variable var. For classes the array descriptor is
5674 in the _data component and the object goes into the
5675 GFC_DECL_SAVED_DESCRIPTOR. */
5676 if (code
->expr3
->ts
.type
== BT_CLASS
5677 && code
->expr3
->rank
!= 0)
5679 /* When an array_ref was in expr3, then the descriptor is the
5681 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5683 desc
= TREE_OPERAND (tmp
, 0);
5688 tmp
= gfc_class_data_get (tmp
);
5690 if (code
->ext
.alloc
.arr_spec_from_expr3
)
5694 desc
= !is_coarray
? se
.expr
5695 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5696 /* We need a regular (non-UID) symbol here, therefore give a
5698 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5699 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5701 gfc_allocate_lang_decl (var
);
5702 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5704 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5707 if (se
.string_length
)
5708 /* Evaluate it assuming that it also is complicated like expr3. */
5709 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5714 expr3_len
= se
.string_length
;
5717 /* Deallocate any allocatable components in expressions that use a
5718 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
5719 E.g. temporaries of a function call need freeing of their components
5721 if ((code
->expr3
->ts
.type
== BT_DERIVED
5722 || code
->expr3
->ts
.type
== BT_CLASS
)
5723 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
5724 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
)
5726 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
5727 expr3
, code
->expr3
->rank
);
5728 gfc_prepend_expr_to_block (&post
, tmp
);
5731 /* Store what the expr3 is to be used for. */
5732 if (e3_is
== E3_UNSET
)
5733 e3_is
= expr3
!= NULL_TREE
?
5734 (code
->ext
.alloc
.arr_spec_from_expr3
?
5736 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
5739 /* Figure how to get the _vtab entry. This also obtains the tree
5740 expression for accessing the _len component, because only
5741 unlimited polymorphic objects, which are a subcategory of class
5742 types, have a _len component. */
5743 if (code
->expr3
->ts
.type
== BT_CLASS
)
5746 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
5747 build_fold_indirect_ref (expr3
): expr3
;
5748 /* Polymorphic SOURCE: VPTR must be determined at run time.
5749 expr3 may be a temporary array declaration, therefore check for
5750 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5751 if (tmp
!= NULL_TREE
5752 && (e3_is
== E3_DESC
5753 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
5754 && (VAR_P (tmp
) || !code
->expr3
->ref
))
5755 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
5756 tmp
= gfc_class_vptr_get (expr3
);
5759 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5760 gfc_add_vptr_component (rhs
);
5761 gfc_init_se (&se
, NULL
);
5762 se
.want_pointer
= 1;
5763 gfc_conv_expr (&se
, rhs
);
5765 gfc_free_expr (rhs
);
5767 /* Set the element size. */
5768 expr3_esize
= gfc_vptr_size_get (tmp
);
5771 /* Initialize the ref to the _len component. */
5772 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5774 /* Same like for retrieving the _vptr. */
5775 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5776 expr3_len
= gfc_class_len_get (expr3
);
5779 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5780 gfc_add_len_component (rhs
);
5781 gfc_init_se (&se
, NULL
);
5782 gfc_conv_expr (&se
, rhs
);
5783 expr3_len
= se
.expr
;
5784 gfc_free_expr (rhs
);
5790 /* When the object to allocate is polymorphic type, then it
5791 needs its vtab set correctly, so deduce the required _vtab
5792 and _len from the source expression. */
5795 /* VPTR is fixed at compile time. */
5798 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5800 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5801 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5804 /* _len component needs to be set, when ts is a character
5806 if (expr3_len
== NULL_TREE
5807 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5809 if (code
->expr3
->ts
.u
.cl
5810 && code
->expr3
->ts
.u
.cl
->length
)
5812 gfc_init_se (&se
, NULL
);
5813 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5814 gfc_add_block_to_block (&block
, &se
.pre
);
5815 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5817 gcc_assert (expr3_len
);
5819 /* For character arrays only the kind's size is needed, because
5820 the array mem_size is _len * (elem_size = kind_size).
5821 For all other get the element size in the normal way. */
5822 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5823 expr3_esize
= TYPE_SIZE_UNIT (
5824 gfc_get_char_type (code
->expr3
->ts
.kind
));
5826 expr3_esize
= TYPE_SIZE_UNIT (
5827 gfc_typenode_for_spec (&code
->expr3
->ts
));
5829 gcc_assert (expr3_esize
);
5830 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5831 if (e3_is
== E3_MOLD
)
5832 /* The expr3 is no longer valid after this point. */
5835 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5837 /* Compute the explicit typespec given only once for all objects
5839 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5840 expr3_esize
= TYPE_SIZE_UNIT (
5841 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5845 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
);
5846 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5847 gfc_init_se (&se_sz
, NULL
);
5848 gfc_conv_expr (&se_sz
, sz
);
5850 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5851 tmp
= TYPE_SIZE_UNIT (tmp
);
5852 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5853 gfc_add_block_to_block (&block
, &se_sz
.pre
);
5854 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5855 TREE_TYPE (se_sz
.expr
),
5857 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
5861 /* The routine gfc_trans_assignment () already implements all
5862 techniques needed. Unfortunately we may have a temporary
5863 variable for the source= expression here. When that is the
5864 case convert this variable into a temporary gfc_expr of type
5865 EXPR_VARIABLE and used it as rhs for the assignment. The
5866 advantage is, that we get scalarizer support for free,
5867 don't have to take care about scalar to array treatment and
5868 will benefit of every enhancements gfc_trans_assignment ()
5870 No need to check whether e3_is is E3_UNSET, because that is
5871 done by expr3 != NULL_TREE.
5872 Exclude variables since the following block does not handle
5873 array sections. In any case, there is no harm in sending
5874 variables to gfc_trans_assignment because there is no
5875 evaluation of variables. */
5878 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
5879 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
5880 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5882 /* Build a temporary symtree and symbol. Do not add it to the current
5883 namespace to prevent accidently modifying a colliding
5885 newsym
= XCNEW (gfc_symtree
);
5886 /* The name of the symtree should be unique, because gfc_create_var ()
5887 took care about generating the identifier. */
5889 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
5890 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5891 /* The backend_decl is known. It is expr3, which is inserted
5893 newsym
->n
.sym
->backend_decl
= expr3
;
5894 e3rhs
= gfc_get_expr ();
5895 e3rhs
->rank
= code
->expr3
->rank
;
5896 e3rhs
->symtree
= newsym
;
5897 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
5898 newsym
->n
.sym
->attr
.referenced
= 1;
5899 e3rhs
->expr_type
= EXPR_VARIABLE
;
5900 e3rhs
->where
= code
->expr3
->where
;
5901 /* Set the symbols type, upto it was BT_UNKNOWN. */
5902 if (IS_CLASS_ARRAY (code
->expr3
)
5903 && code
->expr3
->expr_type
== EXPR_FUNCTION
5904 && code
->expr3
->value
.function
.isym
5905 && code
->expr3
->value
.function
.isym
->transformational
)
5907 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5909 else if (code
->expr3
->ts
.type
== BT_CLASS
5910 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
5911 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5913 e3rhs
->ts
= code
->expr3
->ts
;
5914 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5915 /* Check whether the expr3 is array valued. */
5918 gfc_array_spec
*arr
;
5919 arr
= gfc_get_array_spec ();
5920 arr
->rank
= e3rhs
->rank
;
5921 arr
->type
= AS_DEFERRED
;
5922 /* Set the dimension and pointer attribute for arrays
5923 to be on the safe side. */
5924 newsym
->n
.sym
->attr
.dimension
= 1;
5925 newsym
->n
.sym
->attr
.pointer
= 1;
5926 newsym
->n
.sym
->as
= arr
;
5927 if (IS_CLASS_ARRAY (code
->expr3
)
5928 && code
->expr3
->expr_type
== EXPR_FUNCTION
5929 && code
->expr3
->value
.function
.isym
5930 && code
->expr3
->value
.function
.isym
->transformational
)
5932 gfc_array_spec
*tarr
;
5933 tarr
= gfc_get_array_spec ();
5935 e3rhs
->ts
.u
.derived
->as
= tarr
;
5937 gfc_add_full_array_ref (e3rhs
, arr
);
5939 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
5940 newsym
->n
.sym
->attr
.pointer
= 1;
5941 /* The string length is known, too. Set it for char arrays. */
5942 if (e3rhs
->ts
.type
== BT_CHARACTER
)
5943 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
5944 gfc_commit_symbol (newsym
->n
.sym
);
5947 e3rhs
= gfc_copy_expr (code
->expr3
);
5950 /* Loop over all objects to allocate. */
5951 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5953 expr
= gfc_copy_expr (al
->expr
);
5954 /* UNLIMITED_POLY () needs the _data component to be set, when
5955 expr is a unlimited polymorphic object. But the _data component
5956 has not been set yet, so check the derived type's attr for the
5957 unlimited polymorphic flag to be safe. */
5958 upoly_expr
= UNLIMITED_POLY (expr
)
5959 || (expr
->ts
.type
== BT_DERIVED
5960 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
5961 gfc_init_se (&se
, NULL
);
5963 /* For class types prepare the expressions to ref the _vptr
5964 and the _len component. The latter for unlimited polymorphic
5966 if (expr
->ts
.type
== BT_CLASS
)
5968 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
5969 gfc_add_data_component (expr
);
5970 /* Prep the vptr handle. */
5971 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
5972 gfc_add_vptr_component (expr_ref_vptr
);
5973 se
.want_pointer
= 1;
5974 gfc_conv_expr (&se
, expr_ref_vptr
);
5976 se
.want_pointer
= 0;
5977 gfc_free_expr (expr_ref_vptr
);
5978 /* Allocated unlimited polymorphic objects always have a _len
5982 expr_ref_len
= gfc_copy_expr (al
->expr
);
5983 gfc_add_len_component (expr_ref_len
);
5984 gfc_conv_expr (&se
, expr_ref_len
);
5986 gfc_free_expr (expr_ref_len
);
5989 /* In a loop ensure that all loop variable dependent variables
5990 are initialized at the same spot in all execution paths. */
5994 al_vptr
= al_len
= NULL_TREE
;
5996 se
.want_pointer
= 1;
5997 se
.descriptor_only
= 1;
5999 gfc_conv_expr (&se
, expr
);
6000 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6001 /* se.string_length now stores the .string_length variable of expr
6002 needed to allocate character(len=:) arrays. */
6003 al_len
= se
.string_length
;
6005 al_len_needs_set
= al_len
!= NULL_TREE
;
6006 /* When allocating an array one can not use much of the
6007 pre-evaluated expr3 expressions, because for most of them the
6008 scalarizer is needed which is not available in the pre-evaluation
6009 step. Therefore gfc_array_allocate () is responsible (and able)
6010 to handle the complete array allocation. Only the element size
6011 needs to be provided, which is done most of the time by the
6012 pre-evaluation step. */
6014 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6015 || code
->expr3
->ts
.type
== BT_CLASS
))
6017 /* When al is an array, then the element size for each element
6018 in the array is needed, which is the product of the len and
6019 esize for char arrays. For unlimited polymorphics len can be
6020 zero, therefore take the maximum of len and one. */
6021 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6022 TREE_TYPE (expr3_len
),
6023 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6025 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6026 TREE_TYPE (expr3_esize
), expr3_esize
,
6027 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6031 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6032 label_finish
, tmp
, &nelems
,
6033 e3rhs
? e3rhs
: code
->expr3
,
6034 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6035 code
->expr3
!= NULL
&& e3_is
== E3_DESC
6036 && code
->expr3
->expr_type
== EXPR_ARRAY
))
6038 /* A scalar or derived type. First compute the size to
6041 expr3_len is set when expr3 is an unlimited polymorphic
6042 object or a deferred length string. */
6043 if (expr3_len
!= NULL_TREE
)
6045 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6046 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6047 TREE_TYPE (expr3_esize
),
6049 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6050 /* expr3 is a deferred length string, i.e., we are
6055 /* For unlimited polymorphic enties build
6056 (len > 0) ? element_size * len : element_size
6057 to compute the number of bytes to allocate.
6058 This allows the allocation of unlimited polymorphic
6059 objects from an expr3 that is also unlimited
6060 polymorphic and stores a _len dependent object,
6062 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6063 boolean_type_node
, expr3_len
,
6065 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6066 TREE_TYPE (expr3_esize
),
6067 memsz
, tmp
, expr3_esize
);
6070 else if (expr3_esize
!= NULL_TREE
)
6071 /* Any other object in expr3 just needs element size in
6073 memsz
= expr3_esize
;
6074 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6076 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6078 /* Allocating deferred length char arrays need the length
6079 to allocate in the alloc_type_spec. But also unlimited
6080 polymorphic objects may be allocated as char arrays.
6081 Both are handled here. */
6082 gfc_init_se (&se_sz
, NULL
);
6083 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6084 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6085 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6086 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6087 expr3_len
= se_sz
.expr
;
6088 tmp_expr3_len_flag
= true;
6089 tmp
= TYPE_SIZE_UNIT (
6090 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6091 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6093 fold_convert (TREE_TYPE (tmp
),
6097 else if (expr
->ts
.type
== BT_CHARACTER
)
6099 /* Compute the number of bytes needed to allocate a fixed
6100 length char array. */
6101 gcc_assert (se
.string_length
!= NULL_TREE
);
6102 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6103 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6104 TREE_TYPE (tmp
), tmp
,
6105 fold_convert (TREE_TYPE (tmp
),
6108 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6109 /* Handle all types, where the alloc_type_spec is set. */
6110 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6112 /* Handle size computation of the type declared to alloc. */
6113 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6115 /* Store the caf-attributes for latter use. */
6116 if (flag_coarray
== GFC_FCOARRAY_LIB
6117 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6120 /* Scalar allocatable components in coarray'ed derived types make
6121 it here and are treated now. */
6122 tree caf_decl
, token
;
6126 /* Set flag, to add synchronize after the allocate. */
6127 needs_caf_sync
= needs_caf_sync
6128 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6130 gfc_init_se (&caf_se
, NULL
);
6132 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6133 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6135 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6136 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6137 gfc_build_addr_expr (NULL_TREE
, token
),
6138 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6139 label_finish
, expr
, 1);
6141 /* Allocate - for non-pointers with re-alloc checking. */
6142 else if (gfc_expr_attr (expr
).allocatable
)
6143 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6144 NULL_TREE
, stat
, errmsg
, errlen
,
6145 label_finish
, expr
, 0);
6147 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6151 /* Allocating coarrays needs a sync after the allocate executed.
6152 Set the flag to add the sync after all objects are allocated. */
6153 if (flag_coarray
== GFC_FCOARRAY_LIB
6154 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6158 needs_caf_sync
= needs_caf_sync
6159 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6162 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6163 && expr3_len
!= NULL_TREE
)
6165 /* Arrays need to have a _len set before the array
6166 descriptor is filled. */
6167 gfc_add_modify (&block
, al_len
,
6168 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6169 /* Prevent setting the length twice. */
6170 al_len_needs_set
= false;
6172 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6173 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6175 /* Cover the cases where a string length is explicitly
6176 specified by a type spec for deferred length character
6177 arrays or unlimited polymorphic objects without a
6178 source= or mold= expression. */
6179 gfc_init_se (&se_sz
, NULL
);
6180 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6181 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6182 gfc_add_modify (&block
, al_len
,
6183 fold_convert (TREE_TYPE (al_len
),
6185 al_len_needs_set
= false;
6189 gfc_add_block_to_block (&block
, &se
.pre
);
6191 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6194 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6195 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6196 boolean_type_node
, stat
,
6197 build_int_cst (TREE_TYPE (stat
), 0));
6198 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6199 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6200 tmp
, build_empty_stmt (input_location
));
6201 gfc_add_expr_to_block (&block
, tmp
);
6204 /* Set the vptr only when no source= is set. When source= is set, then
6205 the trans_assignment below will set the vptr. */
6206 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6208 if (expr3_vptr
!= NULL_TREE
)
6209 /* The vtab is already known, so just assign it. */
6210 gfc_add_modify (&block
, al_vptr
,
6211 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6214 /* VPTR is fixed at compile time. */
6219 /* Although expr3 is pre-evaluated above, it may happen,
6220 that for arrays or in mold= cases the pre-evaluation
6221 was not successful. In these rare cases take the vtab
6222 from the typespec of expr3 here. */
6223 ts
= &code
->expr3
->ts
;
6224 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6225 /* The alloc_type_spec gives the type to allocate or the
6226 al is unlimited polymorphic, which enforces the use of
6227 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6228 ts
= &code
->ext
.alloc
.ts
;
6230 /* Prepare for setting the vtab as declared. */
6233 vtab
= gfc_find_vtab (ts
);
6235 tmp
= gfc_build_addr_expr (NULL_TREE
,
6236 gfc_get_symbol_decl (vtab
));
6237 gfc_add_modify (&block
, al_vptr
,
6238 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6242 /* Add assignment for string length. */
6243 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6245 if (expr3_len
!= NULL_TREE
)
6247 gfc_add_modify (&block
, al_len
,
6248 fold_convert (TREE_TYPE (al_len
),
6250 /* When tmp_expr3_len_flag is set, then expr3_len is
6251 abused to carry the length information from the
6252 alloc_type. Clear it to prevent setting incorrect len
6253 information in future loop iterations. */
6254 if (tmp_expr3_len_flag
)
6255 /* No need to reset tmp_expr3_len_flag, because the
6256 presence of an expr3 can not change within in the
6258 expr3_len
= NULL_TREE
;
6260 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6261 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6263 /* Cover the cases where a string length is explicitly
6264 specified by a type spec for deferred length character
6265 arrays or unlimited polymorphic objects without a
6266 source= or mold= expression. */
6267 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6269 gfc_init_se (&se_sz
, NULL
);
6270 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6271 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6272 gfc_add_modify (&block
, al_len
,
6273 fold_convert (TREE_TYPE (al_len
),
6277 gfc_add_modify (&block
, al_len
,
6278 fold_convert (TREE_TYPE (al_len
),
6282 /* No length information needed, because type to allocate
6283 has no length. Set _len to 0. */
6284 gfc_add_modify (&block
, al_len
,
6285 fold_convert (TREE_TYPE (al_len
),
6286 integer_zero_node
));
6290 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6292 /* Initialization via SOURCE block (or static default initializer).
6293 Switch off automatic reallocation since we have just done the
6295 int realloc_lhs
= flag_realloc_lhs
;
6296 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6297 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6298 flag_realloc_lhs
= 0;
6299 tmp
= gfc_trans_assignment (init_expr
, rhs
, false, false, true,
6301 flag_realloc_lhs
= realloc_lhs
;
6302 /* Free the expression allocated for init_expr. */
6303 gfc_free_expr (init_expr
);
6305 gfc_free_expr (rhs
);
6306 gfc_add_expr_to_block (&block
, tmp
);
6308 else if (code
->expr3
&& code
->expr3
->mold
6309 && code
->expr3
->ts
.type
== BT_CLASS
)
6311 /* Use class_init_assign to initialize expr. */
6313 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6314 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
);
6315 tmp
= gfc_trans_class_init_assign (ini
);
6316 gfc_free_statements (ini
);
6317 gfc_add_expr_to_block (&block
, tmp
);
6319 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
6321 /* Use class_init_assign to initialize expr. */
6323 int realloc_lhs
= flag_realloc_lhs
;
6324 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6325 ini
->expr1
= gfc_expr_to_initialize (expr
);
6326 ini
->expr2
= init_expr
;
6327 flag_realloc_lhs
= 0;
6328 tmp
= gfc_trans_init_assign (ini
);
6329 flag_realloc_lhs
= realloc_lhs
;
6330 gfc_free_statements (ini
);
6331 /* Init_expr is freeed by above free_statements, just need to null
6334 gfc_add_expr_to_block (&block
, tmp
);
6337 /* Nullify all pointers in derived type coarrays. This registers a
6338 token for them which allows their allocation. */
6341 gfc_symbol
*type
= NULL
;
6342 symbol_attribute caf_attr
;
6344 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6345 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
6347 type
= code
->ext
.alloc
.ts
.u
.derived
;
6348 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
6349 gfc_clear_attr (&caf_attr
);
6351 else if (expr
->ts
.type
== BT_DERIVED
6352 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
6354 type
= expr
->ts
.u
.derived
;
6356 caf_attr
= gfc_caf_attr (expr
, true);
6359 /* Initialize the tokens of pointer components in derived type
6363 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
6364 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
6365 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
6366 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
6367 gfc_add_expr_to_block (&block
, tmp
);
6371 gfc_free_expr (expr
);
6378 gfc_free_symbol (newsym
->n
.sym
);
6381 gfc_free_expr (e3rhs
);
6386 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6387 gfc_add_expr_to_block (&block
, tmp
);
6390 /* ERRMSG - only useful if STAT is present. */
6391 if (code
->expr1
&& code
->expr2
)
6393 const char *msg
= "Attempt to allocate an allocated object";
6394 tree slen
, dlen
, errmsg_str
;
6395 stmtblock_t errmsg_block
;
6397 gfc_init_block (&errmsg_block
);
6399 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6400 gfc_add_modify (&errmsg_block
, errmsg_str
,
6401 gfc_build_addr_expr (pchar_type_node
,
6402 gfc_build_localized_cstring_const (msg
)));
6404 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6405 dlen
= gfc_get_expr_charlen (code
->expr2
);
6406 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6407 TREE_TYPE (slen
), dlen
, slen
);
6409 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6410 code
->expr2
->ts
.kind
,
6412 gfc_default_character_kind
);
6413 dlen
= gfc_finish_block (&errmsg_block
);
6415 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6416 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6418 tmp
= build3_v (COND_EXPR
, tmp
,
6419 dlen
, build_empty_stmt (input_location
));
6421 gfc_add_expr_to_block (&block
, tmp
);
6427 if (TREE_USED (label_finish
))
6429 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6430 gfc_add_expr_to_block (&block
, tmp
);
6433 gfc_init_se (&se
, NULL
);
6434 gfc_conv_expr_lhs (&se
, code
->expr1
);
6435 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6436 gfc_add_modify (&block
, se
.expr
, tmp
);
6441 /* Add a sync all after the allocation has been executed. */
6442 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
6443 3, null_pointer_node
, null_pointer_node
,
6445 gfc_add_expr_to_block (&post
, tmp
);
6448 gfc_add_block_to_block (&block
, &se
.post
);
6449 gfc_add_block_to_block (&block
, &post
);
6451 return gfc_finish_block (&block
);
6455 /* Translate a DEALLOCATE statement. */
6458 gfc_trans_deallocate (gfc_code
*code
)
6462 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6463 tree label_finish
, label_errmsg
;
6466 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6467 label_finish
= label_errmsg
= NULL_TREE
;
6469 gfc_start_block (&block
);
6471 /* Count the number of failed deallocations. If deallocate() was
6472 called with STAT= , then set STAT to the count. If deallocate
6473 was called with ERRMSG, then set ERRMG to a string. */
6476 tree gfc_int4_type_node
= gfc_get_int_type (4);
6478 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6479 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6481 /* GOTO destinations. */
6482 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6483 label_finish
= gfc_build_label_decl (NULL_TREE
);
6484 TREE_USED (label_finish
) = 0;
6487 /* Set ERRMSG - only needed if STAT is available. */
6488 if (code
->expr1
&& code
->expr2
)
6490 gfc_init_se (&se
, NULL
);
6491 se
.want_pointer
= 1;
6492 gfc_conv_expr_lhs (&se
, code
->expr2
);
6494 errlen
= se
.string_length
;
6497 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6499 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6500 bool is_coarray
= false, is_coarray_array
= false;
6503 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6505 if (expr
->ts
.type
== BT_CLASS
)
6506 gfc_add_data_component (expr
);
6508 gfc_init_se (&se
, NULL
);
6509 gfc_start_block (&se
.pre
);
6511 se
.want_pointer
= 1;
6512 se
.descriptor_only
= 1;
6513 gfc_conv_expr (&se
, expr
);
6515 if (flag_coarray
== GFC_FCOARRAY_LIB
6516 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
6519 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
6520 if (caf_attr
.codimension
)
6523 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
6524 || caf_attr
.coarray_comp
;
6526 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6527 /* When the expression to deallocate is referencing a
6528 component, then only deallocate it, but do not
6530 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
6531 | (comp_ref
&& !caf_attr
.coarray_comp
6532 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
6536 if (expr
->rank
|| is_coarray_array
)
6540 if (gfc_bt_struct (expr
->ts
.type
)
6541 && expr
->ts
.u
.derived
->attr
.alloc_comp
6542 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6544 gfc_ref
*last
= NULL
;
6546 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6547 if (ref
->type
== REF_COMPONENT
)
6550 /* Do not deallocate the components of a derived type
6551 ultimate pointer component. */
6552 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6553 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6555 if (is_coarray
&& expr
->rank
== 0
6556 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
6557 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6559 /* Add the ref to the data member only, when this is not
6560 a regular array or deallocate_alloc_comp will try to
6562 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
6566 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
6567 expr
->rank
, caf_mode
);
6568 gfc_add_expr_to_block (&se
.pre
, tmp
);
6572 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6574 gfc_coarray_deregtype caf_dtype
;
6577 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
6578 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
6579 : GFC_CAF_COARRAY_DEREGISTER
;
6581 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
6582 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
6583 label_finish
, false, expr
,
6585 gfc_add_expr_to_block (&se
.pre
, tmp
);
6587 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6588 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6589 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6592 /* class.c(finalize_component) generates these, when a
6593 finalizable entity has a non-allocatable derived type array
6594 component, which has allocatable components. Obtain the
6595 derived type of the array and deallocate the allocatable
6597 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6599 if (ref
->u
.c
.component
->attr
.dimension
6600 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6604 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6605 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6608 tmp
= gfc_deallocate_alloc_comp
6609 (ref
->u
.c
.component
->ts
.u
.derived
,
6610 se
.expr
, expr
->rank
);
6611 gfc_add_expr_to_block (&se
.pre
, tmp
);
6615 if (al
->expr
->ts
.type
== BT_CLASS
)
6617 gfc_reset_vptr (&se
.pre
, al
->expr
);
6618 if (UNLIMITED_POLY (al
->expr
)
6619 || (al
->expr
->ts
.type
== BT_DERIVED
6620 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6621 /* Clear _len, too. */
6622 gfc_reset_len (&se
.pre
, al
->expr
);
6627 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
6629 al
->expr
->ts
, is_coarray
);
6630 gfc_add_expr_to_block (&se
.pre
, tmp
);
6632 /* Set to zero after deallocation. */
6633 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6635 build_int_cst (TREE_TYPE (se
.expr
), 0));
6636 gfc_add_expr_to_block (&se
.pre
, tmp
);
6638 if (al
->expr
->ts
.type
== BT_CLASS
)
6640 gfc_reset_vptr (&se
.pre
, al
->expr
);
6641 if (UNLIMITED_POLY (al
->expr
)
6642 || (al
->expr
->ts
.type
== BT_DERIVED
6643 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6644 /* Clear _len, too. */
6645 gfc_reset_len (&se
.pre
, al
->expr
);
6653 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6654 build_int_cst (TREE_TYPE (stat
), 0));
6655 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6656 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6657 build1_v (GOTO_EXPR
, label_errmsg
),
6658 build_empty_stmt (input_location
));
6659 gfc_add_expr_to_block (&se
.pre
, tmp
);
6662 tmp
= gfc_finish_block (&se
.pre
);
6663 gfc_add_expr_to_block (&block
, tmp
);
6664 gfc_free_expr (expr
);
6669 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6670 gfc_add_expr_to_block (&block
, tmp
);
6673 /* Set ERRMSG - only needed if STAT is available. */
6674 if (code
->expr1
&& code
->expr2
)
6676 const char *msg
= "Attempt to deallocate an unallocated object";
6677 stmtblock_t errmsg_block
;
6678 tree errmsg_str
, slen
, dlen
, cond
;
6680 gfc_init_block (&errmsg_block
);
6682 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6683 gfc_add_modify (&errmsg_block
, errmsg_str
,
6684 gfc_build_addr_expr (pchar_type_node
,
6685 gfc_build_localized_cstring_const (msg
)));
6686 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6687 dlen
= gfc_get_expr_charlen (code
->expr2
);
6689 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6690 slen
, errmsg_str
, gfc_default_character_kind
);
6691 tmp
= gfc_finish_block (&errmsg_block
);
6693 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6694 build_int_cst (TREE_TYPE (stat
), 0));
6695 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6696 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6697 build_empty_stmt (input_location
));
6699 gfc_add_expr_to_block (&block
, tmp
);
6702 if (code
->expr1
&& TREE_USED (label_finish
))
6704 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6705 gfc_add_expr_to_block (&block
, tmp
);
6711 gfc_init_se (&se
, NULL
);
6712 gfc_conv_expr_lhs (&se
, code
->expr1
);
6713 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6714 gfc_add_modify (&block
, se
.expr
, tmp
);
6717 return gfc_finish_block (&block
);
6720 #include "gt-fortran-trans-stmt.h"