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
, logical_type_node
, tmp
,
154 build_int_cst (TREE_TYPE (tmp
), -1));
155 gfc_trans_runtime_check (true, false, tmp
, &se
.pre
, &loc
,
156 "Assigned label is not a target label");
158 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
160 /* We're going to ignore a label list. It does not really change the
161 statement's semantics (because it is just a further restriction on
162 what's legal code); before, we were comparing label addresses here, but
163 that's a very fragile business and may break with optimization. So
166 target
= fold_build1_loc (input_location
, GOTO_EXPR
, void_type_node
,
168 gfc_add_expr_to_block (&se
.pre
, target
);
169 return gfc_finish_block (&se
.pre
);
173 /* Translate an ENTRY statement. Just adds a label for this entry point. */
175 gfc_trans_entry (gfc_code
* code
)
177 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
181 /* Replace a gfc_ss structure by another both in the gfc_se struct
182 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
183 to replace a variable ss by the corresponding temporary. */
186 replace_ss (gfc_se
*se
, gfc_ss
*old_ss
, gfc_ss
*new_ss
)
188 gfc_ss
**sess
, **loopss
;
190 /* The old_ss is a ss for a single variable. */
191 gcc_assert (old_ss
->info
->type
== GFC_SS_SECTION
);
193 for (sess
= &(se
->ss
); *sess
!= gfc_ss_terminator
; sess
= &((*sess
)->next
))
196 gcc_assert (*sess
!= gfc_ss_terminator
);
199 new_ss
->next
= old_ss
->next
;
202 for (loopss
= &(se
->loop
->ss
); *loopss
!= gfc_ss_terminator
;
203 loopss
= &((*loopss
)->loop_chain
))
204 if (*loopss
== old_ss
)
206 gcc_assert (*loopss
!= gfc_ss_terminator
);
209 new_ss
->loop_chain
= old_ss
->loop_chain
;
210 new_ss
->loop
= old_ss
->loop
;
212 gfc_free_ss (old_ss
);
216 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
217 elemental subroutines. Make temporaries for output arguments if any such
218 dependencies are found. Output arguments are chosen because internal_unpack
219 can be used, as is, to copy the result back to the variable. */
221 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
222 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
223 gfc_dep_check check_variable
)
225 gfc_actual_arglist
*arg0
;
227 gfc_formal_arglist
*formal
;
235 if (loopse
->ss
== NULL
)
240 formal
= gfc_sym_get_dummy_args (sym
);
242 /* Loop over all the arguments testing for dependencies. */
243 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
249 /* Obtain the info structure for the current argument. */
250 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
251 if (ss
->info
->expr
== e
)
254 /* If there is a dependency, create a temporary and use it
255 instead of the variable. */
256 fsym
= formal
? formal
->sym
: NULL
;
257 if (e
->expr_type
== EXPR_VARIABLE
259 && fsym
->attr
.intent
!= INTENT_IN
260 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
261 sym
, arg0
, check_variable
))
263 tree initial
, temptype
;
264 stmtblock_t temp_post
;
267 tmp_ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, ss
->dimen
,
269 gfc_mark_ss_chain_used (tmp_ss
, 1);
270 tmp_ss
->info
->expr
= ss
->info
->expr
;
271 replace_ss (loopse
, ss
, tmp_ss
);
273 /* Obtain the argument descriptor for unpacking. */
274 gfc_init_se (&parmse
, NULL
);
275 parmse
.want_pointer
= 1;
276 gfc_conv_expr_descriptor (&parmse
, e
);
277 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
279 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
280 initialize the array temporary with a copy of the values. */
281 if (fsym
->attr
.intent
== INTENT_INOUT
282 || (fsym
->ts
.type
==BT_DERIVED
283 && fsym
->attr
.intent
== INTENT_OUT
))
284 initial
= parmse
.expr
;
285 /* For class expressions, we always initialize with the copy of
287 else if (e
->ts
.type
== BT_CLASS
)
288 initial
= parmse
.expr
;
292 if (e
->ts
.type
!= BT_CLASS
)
294 /* Find the type of the temporary to create; we don't use the type
295 of e itself as this breaks for subcomponent-references in e
296 (where the type of e is that of the final reference, but
297 parmse.expr's type corresponds to the full derived-type). */
298 /* TODO: Fix this somehow so we don't need a temporary of the whole
299 array but instead only the components referenced. */
300 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
301 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
302 temptype
= TREE_TYPE (temptype
);
303 temptype
= gfc_get_element_type (temptype
);
307 /* For class arrays signal that the size of the dynamic type has to
308 be obtained from the vtable, using the 'initial' expression. */
309 temptype
= NULL_TREE
;
311 /* Generate the temporary. Cleaning up the temporary should be the
312 very last thing done, so we add the code to a new block and add it
313 to se->post as last instructions. */
314 size
= gfc_create_var (gfc_array_index_type
, NULL
);
315 data
= gfc_create_var (pvoid_type_node
, NULL
);
316 gfc_init_block (&temp_post
);
317 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
, tmp_ss
,
318 temptype
, initial
, false, true,
319 false, &arg
->expr
->where
);
320 gfc_add_modify (&se
->pre
, size
, tmp
);
321 tmp
= fold_convert (pvoid_type_node
, tmp_ss
->info
->data
.array
.data
);
322 gfc_add_modify (&se
->pre
, data
, tmp
);
324 /* Update other ss' delta. */
325 gfc_set_delta (loopse
->loop
);
327 /* Copy the result back using unpack..... */
328 if (e
->ts
.type
!= BT_CLASS
)
329 tmp
= build_call_expr_loc (input_location
,
330 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
333 /* ... except for class results where the copy is
335 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
336 tmp
= gfc_conv_descriptor_data_get (tmp
);
337 tmp
= build_call_expr_loc (input_location
,
338 builtin_decl_explicit (BUILT_IN_MEMCPY
),
340 fold_convert (size_type_node
, size
));
342 gfc_add_expr_to_block (&se
->post
, tmp
);
344 /* parmse.pre is already added above. */
345 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
346 gfc_add_block_to_block (&se
->post
, &temp_post
);
352 /* Get the interface symbol for the procedure corresponding to the given call.
353 We can't get the procedure symbol directly as we have to handle the case
354 of (deferred) type-bound procedures. */
357 get_proc_ifc_for_call (gfc_code
*c
)
361 gcc_assert (c
->op
== EXEC_ASSIGN_CALL
|| c
->op
== EXEC_CALL
);
363 sym
= gfc_get_proc_ifc_for_expr (c
->expr1
);
365 /* Fall back/last resort try. */
367 sym
= c
->resolved_sym
;
373 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
376 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
377 tree mask
, tree count1
, bool invert
)
381 int has_alternate_specifier
;
382 gfc_dep_check check_variable
;
383 tree index
= NULL_TREE
;
384 tree maskexpr
= NULL_TREE
;
387 /* A CALL starts a new block because the actual arguments may have to
388 be evaluated first. */
389 gfc_init_se (&se
, NULL
);
390 gfc_start_block (&se
.pre
);
392 gcc_assert (code
->resolved_sym
);
394 ss
= gfc_ss_terminator
;
395 if (code
->resolved_sym
->attr
.elemental
)
396 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
,
397 get_proc_ifc_for_call (code
),
400 /* Is not an elemental subroutine call with array valued arguments. */
401 if (ss
== gfc_ss_terminator
)
404 /* Translate the call. */
405 has_alternate_specifier
406 = gfc_conv_procedure_call (&se
, code
->resolved_sym
, code
->ext
.actual
,
409 /* A subroutine without side-effect, by definition, does nothing! */
410 TREE_SIDE_EFFECTS (se
.expr
) = 1;
412 /* Chain the pieces together and return the block. */
413 if (has_alternate_specifier
)
415 gfc_code
*select_code
;
417 select_code
= code
->next
;
418 gcc_assert(select_code
->op
== EXEC_SELECT
);
419 sym
= select_code
->expr1
->symtree
->n
.sym
;
420 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
421 if (sym
->backend_decl
== NULL
)
422 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
423 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
426 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
428 gfc_add_block_to_block (&se
.pre
, &se
.post
);
433 /* An elemental subroutine call with array valued arguments has
441 /* gfc_walk_elemental_function_args renders the ss chain in the
442 reverse order to the actual argument order. */
443 ss
= gfc_reverse_ss (ss
);
445 /* Initialize the loop. */
446 gfc_init_se (&loopse
, NULL
);
447 gfc_init_loopinfo (&loop
);
448 gfc_add_ss_to_loop (&loop
, ss
);
450 gfc_conv_ss_startstride (&loop
);
451 /* TODO: gfc_conv_loop_setup generates a temporary for vector
452 subscripts. This could be prevented in the elemental case
453 as temporaries are handled separatedly
454 (below in gfc_conv_elemental_dependencies). */
456 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
458 gfc_conv_loop_setup (&loop
, &code
->loc
);
460 gfc_mark_ss_chain_used (ss
, 1);
462 /* Convert the arguments, checking for dependencies. */
463 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
466 /* For operator assignment, do dependency checking. */
467 if (dependency_check
)
468 check_variable
= ELEM_CHECK_VARIABLE
;
470 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
472 gfc_init_se (&depse
, NULL
);
473 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
474 code
->ext
.actual
, check_variable
);
476 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
477 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
479 /* Generate the loop body. */
480 gfc_start_scalarized_body (&loop
, &body
);
481 gfc_init_block (&block
);
485 /* Form the mask expression according to the mask. */
487 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
489 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
490 TREE_TYPE (maskexpr
), maskexpr
);
493 /* Add the subroutine call to the block. */
494 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
495 code
->ext
.actual
, code
->expr1
,
500 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
501 build_empty_stmt (input_location
));
502 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
503 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
504 gfc_array_index_type
,
505 count1
, gfc_index_one_node
);
506 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
509 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
511 gfc_add_block_to_block (&block
, &loopse
.pre
);
512 gfc_add_block_to_block (&block
, &loopse
.post
);
514 /* Finish up the loop block and the loop. */
515 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
516 gfc_trans_scalarizing_loops (&loop
, &body
);
517 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
518 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
519 gfc_add_block_to_block (&se
.pre
, &se
.post
);
520 gfc_cleanup_loop (&loop
);
523 return gfc_finish_block (&se
.pre
);
527 /* Translate the RETURN statement. */
530 gfc_trans_return (gfc_code
* code
)
538 /* If code->expr is not NULL, this return statement must appear
539 in a subroutine and current_fake_result_decl has already
542 result
= gfc_get_fake_result_decl (NULL
, 0);
546 "An alternate return at %L without a * dummy argument",
547 &code
->expr1
->where
);
548 return gfc_generate_return ();
551 /* Start a new block for this statement. */
552 gfc_init_se (&se
, NULL
);
553 gfc_start_block (&se
.pre
);
555 gfc_conv_expr (&se
, code
->expr1
);
557 /* Note that the actually returned expression is a simple value and
558 does not depend on any pointers or such; thus we can clean-up with
559 se.post before returning. */
560 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
561 result
, fold_convert (TREE_TYPE (result
),
563 gfc_add_expr_to_block (&se
.pre
, tmp
);
564 gfc_add_block_to_block (&se
.pre
, &se
.post
);
566 tmp
= gfc_generate_return ();
567 gfc_add_expr_to_block (&se
.pre
, tmp
);
568 return gfc_finish_block (&se
.pre
);
571 return gfc_generate_return ();
575 /* Translate the PAUSE statement. We have to translate this statement
576 to a runtime library call. */
579 gfc_trans_pause (gfc_code
* code
)
581 tree gfc_int4_type_node
= gfc_get_int_type (4);
585 /* Start a new block for this statement. */
586 gfc_init_se (&se
, NULL
);
587 gfc_start_block (&se
.pre
);
590 if (code
->expr1
== NULL
)
592 tmp
= build_int_cst (gfc_int4_type_node
, 0);
593 tmp
= build_call_expr_loc (input_location
,
594 gfor_fndecl_pause_string
, 2,
595 build_int_cst (pchar_type_node
, 0), tmp
);
597 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
599 gfc_conv_expr (&se
, code
->expr1
);
600 tmp
= build_call_expr_loc (input_location
,
601 gfor_fndecl_pause_numeric
, 1,
602 fold_convert (gfc_int4_type_node
, se
.expr
));
606 gfc_conv_expr_reference (&se
, code
->expr1
);
607 tmp
= build_call_expr_loc (input_location
,
608 gfor_fndecl_pause_string
, 2,
609 se
.expr
, se
.string_length
);
612 gfc_add_expr_to_block (&se
.pre
, tmp
);
614 gfc_add_block_to_block (&se
.pre
, &se
.post
);
616 return gfc_finish_block (&se
.pre
);
620 /* Translate the STOP statement. We have to translate this statement
621 to a runtime library call. */
624 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
626 tree gfc_int4_type_node
= gfc_get_int_type (4);
630 /* Start a new block for this statement. */
631 gfc_init_se (&se
, NULL
);
632 gfc_start_block (&se
.pre
);
634 if (code
->expr1
== NULL
)
636 tmp
= build_int_cst (gfc_int4_type_node
, 0);
637 tmp
= build_call_expr_loc (input_location
,
639 ? (flag_coarray
== GFC_FCOARRAY_LIB
640 ? gfor_fndecl_caf_error_stop_str
641 : gfor_fndecl_error_stop_string
)
642 : (flag_coarray
== GFC_FCOARRAY_LIB
643 ? gfor_fndecl_caf_stop_str
644 : gfor_fndecl_stop_string
),
645 2, build_int_cst (pchar_type_node
, 0), tmp
);
647 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
649 gfc_conv_expr (&se
, code
->expr1
);
650 tmp
= build_call_expr_loc (input_location
,
652 ? (flag_coarray
== GFC_FCOARRAY_LIB
653 ? gfor_fndecl_caf_error_stop
654 : gfor_fndecl_error_stop_numeric
)
655 : (flag_coarray
== GFC_FCOARRAY_LIB
656 ? gfor_fndecl_caf_stop_numeric
657 : gfor_fndecl_stop_numeric
), 1,
658 fold_convert (gfc_int4_type_node
, se
.expr
));
662 gfc_conv_expr_reference (&se
, code
->expr1
);
663 tmp
= build_call_expr_loc (input_location
,
665 ? (flag_coarray
== GFC_FCOARRAY_LIB
666 ? gfor_fndecl_caf_error_stop_str
667 : gfor_fndecl_error_stop_string
)
668 : (flag_coarray
== GFC_FCOARRAY_LIB
669 ? gfor_fndecl_caf_stop_str
670 : gfor_fndecl_stop_string
),
671 2, se
.expr
, se
.string_length
);
674 gfc_add_expr_to_block (&se
.pre
, tmp
);
676 gfc_add_block_to_block (&se
.pre
, &se
.post
);
678 return gfc_finish_block (&se
.pre
);
681 /* Translate the FAIL IMAGE statement. */
684 gfc_trans_fail_image (gfc_code
*code ATTRIBUTE_UNUSED
)
686 if (flag_coarray
== GFC_FCOARRAY_LIB
)
687 return build_call_expr_loc (input_location
,
688 gfor_fndecl_caf_fail_image
, 1,
689 build_int_cst (pchar_type_node
, 0));
692 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
693 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
694 tree tmp
= gfc_get_symbol_decl (exsym
);
695 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
701 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
704 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
705 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
707 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
708 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
709 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
714 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
715 gfc_init_se (&argse
, NULL
);
716 gfc_conv_expr_val (&argse
, code
->expr2
);
719 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
720 stat
= null_pointer_node
;
724 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
725 gfc_init_se (&argse
, NULL
);
726 gfc_conv_expr_val (&argse
, code
->expr4
);
727 lock_acquired
= argse
.expr
;
729 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
730 lock_acquired
= null_pointer_node
;
732 gfc_start_block (&se
.pre
);
733 if (flag_coarray
== GFC_FCOARRAY_LIB
)
735 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
736 tree index
= size_zero_node
;
737 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
739 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
740 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
741 != INTMOD_ISO_FORTRAN_ENV
742 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
743 != ISOFORTRAN_LOCK_TYPE
)
745 gfc_error ("Sorry, the lock component of derived type at %L is not "
746 "yet supported", &code
->expr1
->where
);
750 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
753 if (gfc_is_coindexed (code
->expr1
))
754 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
756 image_index
= integer_zero_node
;
758 /* For arrays, obtain the array index. */
759 if (gfc_expr_attr (code
->expr1
).dimension
)
761 tree desc
, tmp
, extent
, lbound
, ubound
;
762 gfc_array_ref
*ar
, ar2
;
765 /* TODO: Extend this, once DT components are supported. */
766 ar
= &code
->expr1
->ref
->u
.ar
;
768 memset (ar
, '\0', sizeof (*ar
));
772 gfc_init_se (&argse
, NULL
);
773 argse
.descriptor_only
= 1;
774 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
775 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
779 extent
= integer_one_node
;
780 for (i
= 0; i
< ar
->dimen
; i
++)
782 gfc_init_se (&argse
, NULL
);
783 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
784 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
785 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
786 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
787 integer_type_node
, argse
.expr
,
788 fold_convert(integer_type_node
, lbound
));
789 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
790 integer_type_node
, extent
, tmp
);
791 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
792 integer_type_node
, index
, tmp
);
793 if (i
< ar
->dimen
- 1)
795 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
796 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
797 tmp
= fold_convert (integer_type_node
, tmp
);
798 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
799 integer_type_node
, extent
, tmp
);
807 gfc_init_se (&argse
, NULL
);
808 argse
.want_pointer
= 1;
809 gfc_conv_expr (&argse
, code
->expr3
);
810 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
812 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
816 errmsg
= null_pointer_node
;
817 errmsg_len
= integer_zero_node
;
820 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
823 stat
= gfc_create_var (integer_type_node
, "stat");
826 if (lock_acquired
!= null_pointer_node
827 && TREE_TYPE (lock_acquired
) != integer_type_node
)
829 lock_acquired2
= lock_acquired
;
830 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
834 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
835 token
, index
, image_index
,
836 lock_acquired
!= null_pointer_node
837 ? gfc_build_addr_expr (NULL
, lock_acquired
)
839 stat
!= null_pointer_node
840 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
843 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
844 token
, index
, image_index
,
845 stat
!= null_pointer_node
846 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
848 gfc_add_expr_to_block (&se
.pre
, tmp
);
850 /* It guarantees memory consistency within the same segment */
851 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
852 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
853 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
854 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
855 ASM_VOLATILE_P (tmp
) = 1;
857 gfc_add_expr_to_block (&se
.pre
, tmp
);
859 if (stat2
!= NULL_TREE
)
860 gfc_add_modify (&se
.pre
, stat2
,
861 fold_convert (TREE_TYPE (stat2
), stat
));
863 if (lock_acquired2
!= NULL_TREE
)
864 gfc_add_modify (&se
.pre
, lock_acquired2
,
865 fold_convert (TREE_TYPE (lock_acquired2
),
868 return gfc_finish_block (&se
.pre
);
871 if (stat
!= NULL_TREE
)
872 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
874 if (lock_acquired
!= NULL_TREE
)
875 gfc_add_modify (&se
.pre
, lock_acquired
,
876 fold_convert (TREE_TYPE (lock_acquired
),
879 return gfc_finish_block (&se
.pre
);
883 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
886 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
887 tree until_count
= NULL_TREE
;
891 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
892 gfc_init_se (&argse
, NULL
);
893 gfc_conv_expr_val (&argse
, code
->expr2
);
896 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
897 stat
= null_pointer_node
;
901 gfc_init_se (&argse
, NULL
);
902 gfc_conv_expr_val (&argse
, code
->expr4
);
903 until_count
= fold_convert (integer_type_node
, argse
.expr
);
906 until_count
= integer_one_node
;
908 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
910 gfc_start_block (&se
.pre
);
911 gfc_init_se (&argse
, NULL
);
912 gfc_conv_expr_val (&argse
, code
->expr1
);
914 if (op
== EXEC_EVENT_POST
)
915 gfc_add_modify (&se
.pre
, argse
.expr
,
916 fold_build2_loc (input_location
, PLUS_EXPR
,
917 TREE_TYPE (argse
.expr
), argse
.expr
,
918 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
920 gfc_add_modify (&se
.pre
, argse
.expr
,
921 fold_build2_loc (input_location
, MINUS_EXPR
,
922 TREE_TYPE (argse
.expr
), argse
.expr
,
923 fold_convert (TREE_TYPE (argse
.expr
),
925 if (stat
!= NULL_TREE
)
926 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
928 return gfc_finish_block (&se
.pre
);
931 gfc_start_block (&se
.pre
);
932 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
933 tree index
= size_zero_node
;
934 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
936 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
937 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
938 != INTMOD_ISO_FORTRAN_ENV
939 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
940 != ISOFORTRAN_EVENT_TYPE
)
942 gfc_error ("Sorry, the event component of derived type at %L is not "
943 "yet supported", &code
->expr1
->where
);
947 gfc_init_se (&argse
, NULL
);
948 gfc_get_caf_token_offset (&argse
, &token
, NULL
, caf_decl
, NULL_TREE
,
950 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
952 if (gfc_is_coindexed (code
->expr1
))
953 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
955 image_index
= integer_zero_node
;
957 /* For arrays, obtain the array index. */
958 if (gfc_expr_attr (code
->expr1
).dimension
)
960 tree desc
, tmp
, extent
, lbound
, ubound
;
961 gfc_array_ref
*ar
, ar2
;
964 /* TODO: Extend this, once DT components are supported. */
965 ar
= &code
->expr1
->ref
->u
.ar
;
967 memset (ar
, '\0', sizeof (*ar
));
971 gfc_init_se (&argse
, NULL
);
972 argse
.descriptor_only
= 1;
973 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
974 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
978 extent
= integer_one_node
;
979 for (i
= 0; i
< ar
->dimen
; i
++)
981 gfc_init_se (&argse
, NULL
);
982 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
983 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
984 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
985 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
986 integer_type_node
, argse
.expr
,
987 fold_convert(integer_type_node
, lbound
));
988 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
989 integer_type_node
, extent
, tmp
);
990 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
991 integer_type_node
, index
, tmp
);
992 if (i
< ar
->dimen
- 1)
994 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
995 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
996 tmp
= fold_convert (integer_type_node
, tmp
);
997 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
998 integer_type_node
, extent
, tmp
);
1006 gfc_init_se (&argse
, NULL
);
1007 argse
.want_pointer
= 1;
1008 gfc_conv_expr (&argse
, code
->expr3
);
1009 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1010 errmsg
= argse
.expr
;
1011 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
1015 errmsg
= null_pointer_node
;
1016 errmsg_len
= integer_zero_node
;
1019 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
1022 stat
= gfc_create_var (integer_type_node
, "stat");
1025 if (op
== EXEC_EVENT_POST
)
1026 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1027 token
, index
, image_index
,
1028 stat
!= null_pointer_node
1029 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1030 errmsg
, errmsg_len
);
1032 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1033 token
, index
, until_count
,
1034 stat
!= null_pointer_node
1035 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1036 errmsg
, errmsg_len
);
1037 gfc_add_expr_to_block (&se
.pre
, tmp
);
1039 /* It guarantees memory consistency within the same segment */
1040 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1041 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1042 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1043 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1044 ASM_VOLATILE_P (tmp
) = 1;
1045 gfc_add_expr_to_block (&se
.pre
, tmp
);
1047 if (stat2
!= NULL_TREE
)
1048 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1050 return gfc_finish_block (&se
.pre
);
1054 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1058 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1059 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1061 /* Short cut: For single images without bound checking or without STAT=,
1062 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1063 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1064 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1067 gfc_init_se (&se
, NULL
);
1068 gfc_start_block (&se
.pre
);
1070 if (code
->expr1
&& code
->expr1
->rank
== 0)
1072 gfc_init_se (&argse
, NULL
);
1073 gfc_conv_expr_val (&argse
, code
->expr1
);
1074 images
= argse
.expr
;
1079 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1080 gfc_init_se (&argse
, NULL
);
1081 gfc_conv_expr_val (&argse
, code
->expr2
);
1085 stat
= null_pointer_node
;
1087 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1089 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
1090 gfc_init_se (&argse
, NULL
);
1091 argse
.want_pointer
= 1;
1092 gfc_conv_expr (&argse
, code
->expr3
);
1093 gfc_conv_string_parameter (&argse
);
1094 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1095 errmsglen
= argse
.string_length
;
1097 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1099 errmsg
= null_pointer_node
;
1100 errmsglen
= build_int_cst (integer_type_node
, 0);
1103 /* Check SYNC IMAGES(imageset) for valid image index.
1104 FIXME: Add a check for image-set arrays. */
1105 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1106 && code
->expr1
->rank
== 0)
1109 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1110 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1111 images
, build_int_cst (TREE_TYPE (images
), 1));
1115 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1116 2, integer_zero_node
,
1117 build_int_cst (integer_type_node
, -1));
1118 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1120 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1122 build_int_cst (TREE_TYPE (images
), 1));
1123 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1124 logical_type_node
, cond
, cond2
);
1126 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1127 &code
->expr1
->where
, "Invalid image number "
1128 "%d in SYNC IMAGES",
1129 fold_convert (integer_type_node
, images
));
1132 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1133 image control statements SYNC IMAGES and SYNC ALL. */
1134 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1136 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1137 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1138 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1139 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1140 ASM_VOLATILE_P (tmp
) = 1;
1141 gfc_add_expr_to_block (&se
.pre
, tmp
);
1144 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1146 /* Set STAT to zero. */
1148 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1150 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1152 /* SYNC ALL => stat == null_pointer_node
1153 SYNC ALL(stat=s) => stat has an integer type
1155 If "stat" has the wrong integer type, use a temp variable of
1156 the right type and later cast the result back into "stat". */
1157 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1159 if (TREE_TYPE (stat
) == integer_type_node
)
1160 stat
= gfc_build_addr_expr (NULL
, stat
);
1162 if(type
== EXEC_SYNC_MEMORY
)
1163 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1164 3, stat
, errmsg
, errmsglen
);
1166 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1167 3, stat
, errmsg
, errmsglen
);
1169 gfc_add_expr_to_block (&se
.pre
, tmp
);
1173 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1175 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1176 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1178 gfc_add_expr_to_block (&se
.pre
, tmp
);
1180 gfc_add_modify (&se
.pre
, stat
,
1181 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1188 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1192 len
= build_int_cst (integer_type_node
, -1);
1193 images
= null_pointer_node
;
1195 else if (code
->expr1
->rank
== 0)
1197 len
= build_int_cst (integer_type_node
, 1);
1198 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1203 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1204 gfc_fatal_error ("Sorry, only support for integer kind %d "
1205 "implemented for image-set at %L",
1206 gfc_c_int_kind
, &code
->expr1
->where
);
1208 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1211 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1212 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1213 tmp
= gfc_get_element_type (tmp
);
1215 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1216 TREE_TYPE (len
), len
,
1217 fold_convert (TREE_TYPE (len
),
1218 TYPE_SIZE_UNIT (tmp
)));
1219 len
= fold_convert (integer_type_node
, len
);
1222 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1223 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1225 If "stat" has the wrong integer type, use a temp variable of
1226 the right type and later cast the result back into "stat". */
1227 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1229 if (TREE_TYPE (stat
) == integer_type_node
)
1230 stat
= gfc_build_addr_expr (NULL
, stat
);
1232 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1233 5, fold_convert (integer_type_node
, len
),
1234 images
, stat
, errmsg
, errmsglen
);
1235 gfc_add_expr_to_block (&se
.pre
, tmp
);
1239 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1241 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1242 5, fold_convert (integer_type_node
, len
),
1243 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1245 gfc_add_expr_to_block (&se
.pre
, tmp
);
1247 gfc_add_modify (&se
.pre
, stat
,
1248 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1252 return gfc_finish_block (&se
.pre
);
1256 /* Generate GENERIC for the IF construct. This function also deals with
1257 the simple IF statement, because the front end translates the IF
1258 statement into an IF construct.
1290 where COND_S is the simplified version of the predicate. PRE_COND_S
1291 are the pre side-effects produced by the translation of the
1293 We need to build the chain recursively otherwise we run into
1294 problems with folding incomplete statements. */
1297 gfc_trans_if_1 (gfc_code
* code
)
1300 tree stmt
, elsestmt
;
1304 /* Check for an unconditional ELSE clause. */
1306 return gfc_trans_code (code
->next
);
1308 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1309 gfc_init_se (&if_se
, NULL
);
1310 gfc_start_block (&if_se
.pre
);
1312 /* Calculate the IF condition expression. */
1313 if (code
->expr1
->where
.lb
)
1315 gfc_save_backend_locus (&saved_loc
);
1316 gfc_set_backend_locus (&code
->expr1
->where
);
1319 gfc_conv_expr_val (&if_se
, code
->expr1
);
1321 if (code
->expr1
->where
.lb
)
1322 gfc_restore_backend_locus (&saved_loc
);
1324 /* Translate the THEN clause. */
1325 stmt
= gfc_trans_code (code
->next
);
1327 /* Translate the ELSE clause. */
1329 elsestmt
= gfc_trans_if_1 (code
->block
);
1331 elsestmt
= build_empty_stmt (input_location
);
1333 /* Build the condition expression and add it to the condition block. */
1334 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1335 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1338 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1340 /* Finish off this statement. */
1341 return gfc_finish_block (&if_se
.pre
);
1345 gfc_trans_if (gfc_code
* code
)
1350 /* Create exit label so it is available for trans'ing the body code. */
1351 exit_label
= gfc_build_label_decl (NULL_TREE
);
1352 code
->exit_label
= exit_label
;
1354 /* Translate the actual code in code->block. */
1355 gfc_init_block (&body
);
1356 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1358 /* Add exit label. */
1359 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1361 return gfc_finish_block (&body
);
1365 /* Translate an arithmetic IF expression.
1367 IF (cond) label1, label2, label3 translates to
1379 An optimized version can be generated in case of equal labels.
1380 E.g., if label1 is equal to label2, we can translate it to
1389 gfc_trans_arithmetic_if (gfc_code
* code
)
1397 /* Start a new block. */
1398 gfc_init_se (&se
, NULL
);
1399 gfc_start_block (&se
.pre
);
1401 /* Pre-evaluate COND. */
1402 gfc_conv_expr_val (&se
, code
->expr1
);
1403 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1405 /* Build something to compare with. */
1406 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1408 if (code
->label1
->value
!= code
->label2
->value
)
1410 /* If (cond < 0) take branch1 else take branch2.
1411 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1412 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1413 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1415 if (code
->label1
->value
!= code
->label3
->value
)
1416 tmp
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1419 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1422 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1423 tmp
, branch1
, branch2
);
1426 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1428 if (code
->label1
->value
!= code
->label3
->value
1429 && code
->label2
->value
!= code
->label3
->value
)
1431 /* if (cond <= 0) take branch1 else take branch2. */
1432 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1433 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1435 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1436 tmp
, branch1
, branch2
);
1439 /* Append the COND_EXPR to the evaluation of COND, and return. */
1440 gfc_add_expr_to_block (&se
.pre
, branch1
);
1441 return gfc_finish_block (&se
.pre
);
1445 /* Translate a CRITICAL block. */
1447 gfc_trans_critical (gfc_code
*code
)
1450 tree tmp
, token
= NULL_TREE
;
1452 gfc_start_block (&block
);
1454 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1456 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1457 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1458 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1459 token
, integer_zero_node
, integer_one_node
,
1460 null_pointer_node
, null_pointer_node
,
1461 null_pointer_node
, integer_zero_node
);
1462 gfc_add_expr_to_block (&block
, tmp
);
1464 /* It guarantees memory consistency within the same segment */
1465 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1466 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1467 gfc_build_string_const (1, ""),
1468 NULL_TREE
, NULL_TREE
,
1469 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1471 ASM_VOLATILE_P (tmp
) = 1;
1473 gfc_add_expr_to_block (&block
, tmp
);
1476 tmp
= gfc_trans_code (code
->block
->next
);
1477 gfc_add_expr_to_block (&block
, tmp
);
1479 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1481 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1482 token
, integer_zero_node
, integer_one_node
,
1483 null_pointer_node
, null_pointer_node
,
1485 gfc_add_expr_to_block (&block
, tmp
);
1487 /* It guarantees memory consistency within the same segment */
1488 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1489 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1490 gfc_build_string_const (1, ""),
1491 NULL_TREE
, NULL_TREE
,
1492 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1494 ASM_VOLATILE_P (tmp
) = 1;
1496 gfc_add_expr_to_block (&block
, tmp
);
1499 return gfc_finish_block (&block
);
1503 /* Return true, when the class has a _len component. */
1506 class_has_len_component (gfc_symbol
*sym
)
1508 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1511 if (strcmp (comp
->name
, "_len") == 0)
1519 /* Do proper initialization for ASSOCIATE names. */
1522 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1533 bool need_len_assign
;
1534 bool whole_array
= true;
1536 symbol_attribute attr
;
1538 gcc_assert (sym
->assoc
);
1539 e
= sym
->assoc
->target
;
1541 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1542 && (gfc_is_class_scalar_expr (e
)
1543 || gfc_is_class_array_ref (e
, NULL
));
1545 unlimited
= UNLIMITED_POLY (e
);
1547 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1548 if (ref
->type
== REF_ARRAY
1549 && ref
->u
.ar
.type
== AR_FULL
1552 whole_array
= false;
1556 /* Assignments to the string length need to be generated, when
1557 ( sym is a char array or
1558 sym has a _len component)
1559 and the associated expression is unlimited polymorphic, which is
1560 not (yet) correctly in 'unlimited', because for an already associated
1561 BT_DERIVED the u-poly flag is not set, i.e.,
1562 __tmp_CHARACTER_0_1 => w => arg
1563 ^ generated temp ^ from code, the w does not have the u-poly
1564 flag set, where UNLIMITED_POLY(e) expects it. */
1565 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1566 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1567 && (sym
->ts
.type
== BT_CHARACTER
1568 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1569 && class_has_len_component (sym
))));
1570 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1571 to array temporary) for arrays with either unknown shape or if associating
1573 if (sym
->attr
.dimension
&& !class_target
1574 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1578 bool cst_array_ctor
;
1580 desc
= sym
->backend_decl
;
1581 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1582 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1584 /* If association is to an expression, evaluate it and create temporary.
1585 Otherwise, get descriptor of target for pointer assignment. */
1586 gfc_init_se (&se
, NULL
);
1587 if (sym
->assoc
->variable
|| cst_array_ctor
)
1589 se
.direct_byref
= 1;
1594 gfc_conv_expr_descriptor (&se
, e
);
1596 if (sym
->ts
.type
== BT_CHARACTER
1598 && !sym
->attr
.select_type_temporary
1599 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1600 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1602 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1603 fold_convert (gfc_charlen_type_node
,
1607 /* If we didn't already do the pointer assignment, set associate-name
1608 descriptor to the one generated for the temporary. */
1609 if ((!sym
->assoc
->variable
&& !cst_array_ctor
)
1615 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1617 /* The generated descriptor has lower bound zero (as array
1618 temporary), shift bounds so we get lower bounds of 1. */
1619 for (dim
= 0; dim
< e
->rank
; ++dim
)
1620 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1621 dim
, gfc_index_one_node
);
1624 /* If this is a subreference array pointer associate name use the
1625 associate variable element size for the value of 'span'. */
1626 if (sym
->attr
.subref_array_pointer
)
1628 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1629 tmp
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1630 ? gfc_class_data_get (e
->symtree
->n
.sym
->backend_decl
)
1631 : e
->symtree
->n
.sym
->backend_decl
;
1632 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1633 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1634 gfc_conv_descriptor_span_set (&se
.pre
, desc
, tmp
);
1637 /* Done, register stuff as init / cleanup code. */
1638 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1639 gfc_finish_block (&se
.post
));
1642 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1643 arrays to be assigned directly. */
1644 else if (class_target
&& sym
->attr
.dimension
1645 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1649 gfc_init_se (&se
, NULL
);
1650 se
.descriptor_only
= 1;
1651 /* In a select type the (temporary) associate variable shall point to
1652 a standard fortran array (lower bound == 1), but conv_expr ()
1653 just maps to the input array in the class object, whose lbound may
1654 be arbitrary. conv_expr_descriptor solves this by inserting a
1655 temporary array descriptor. */
1656 gfc_conv_expr_descriptor (&se
, e
);
1658 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1659 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1660 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1662 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1664 if (INDIRECT_REF_P (se
.expr
))
1665 tmp
= TREE_OPERAND (se
.expr
, 0);
1669 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1670 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1673 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1677 /* Recover the dtype, which has been overwritten by the
1678 assignment from an unlimited polymorphic object. */
1679 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1680 gfc_add_modify (&se
.pre
, tmp
,
1681 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1684 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1685 gfc_finish_block (&se
.post
));
1688 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1689 else if (gfc_is_associate_pointer (sym
))
1693 gcc_assert (!sym
->attr
.dimension
);
1695 gfc_init_se (&se
, NULL
);
1697 /* Class associate-names come this way because they are
1698 unconditionally associate pointers and the symbol is scalar. */
1699 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1702 /* For a class array we need a descriptor for the selector. */
1703 gfc_conv_expr_descriptor (&se
, e
);
1704 /* Needed to get/set the _len component below. */
1705 target_expr
= se
.expr
;
1707 /* Obtain a temporary class container for the result. */
1708 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1709 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1711 /* Set the offset. */
1712 desc
= gfc_class_data_get (se
.expr
);
1713 offset
= gfc_index_zero_node
;
1714 for (n
= 0; n
< e
->rank
; n
++)
1716 dim
= gfc_rank_cst
[n
];
1717 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1718 gfc_array_index_type
,
1719 gfc_conv_descriptor_stride_get (desc
, dim
),
1720 gfc_conv_descriptor_lbound_get (desc
, dim
));
1721 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1722 gfc_array_index_type
,
1725 if (need_len_assign
)
1728 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1729 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1730 /* Use the original class descriptor stored in the saved
1731 descriptor to get the target_expr. */
1733 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1735 /* Strip the _data component from the target_expr. */
1736 target_expr
= TREE_OPERAND (target_expr
, 0);
1737 /* Add a reference to the _len comp to the target expr. */
1738 tmp
= gfc_class_len_get (target_expr
);
1739 /* Get the component-ref for the temp structure's _len comp. */
1740 charlen
= gfc_class_len_get (se
.expr
);
1741 /* Add the assign to the beginning of the block... */
1742 gfc_add_modify (&se
.pre
, charlen
,
1743 fold_convert (TREE_TYPE (charlen
), tmp
));
1744 /* and the oposite way at the end of the block, to hand changes
1745 on the string length back. */
1746 gfc_add_modify (&se
.post
, tmp
,
1747 fold_convert (TREE_TYPE (tmp
), charlen
));
1748 /* Length assignment done, prevent adding it again below. */
1749 need_len_assign
= false;
1751 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1753 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1754 && CLASS_DATA (e
)->attr
.dimension
)
1756 /* This is bound to be a class array element. */
1757 gfc_conv_expr_reference (&se
, e
);
1758 /* Get the _vptr component of the class object. */
1759 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1760 /* Obtain a temporary class container for the result. */
1761 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1762 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1766 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1767 which has the string length included. For CHARACTERS it is still
1768 needed and will be done at the end of this routine. */
1769 gfc_conv_expr (&se
, e
);
1770 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1773 if (sym
->ts
.type
== BT_CHARACTER
1775 && !sym
->attr
.select_type_temporary
1776 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1777 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1779 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1780 fold_convert (gfc_charlen_type_node
,
1782 if (e
->expr_type
== EXPR_FUNCTION
)
1784 tmp
= gfc_call_free (sym
->backend_decl
);
1785 gfc_add_expr_to_block (&se
.post
, tmp
);
1789 attr
= gfc_expr_attr (e
);
1790 if (sym
->ts
.type
== BT_CHARACTER
&& e
->ts
.type
== BT_CHARACTER
1791 && (attr
.allocatable
|| attr
.pointer
|| attr
.dummy
))
1793 /* These are pointer types already. */
1794 tmp
= fold_convert (TREE_TYPE (sym
->backend_decl
), se
.expr
);
1798 tmp
= TREE_TYPE (sym
->backend_decl
);
1799 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1802 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1804 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1805 gfc_finish_block (&se
.post
));
1808 /* Do a simple assignment. This is for scalar expressions, where we
1809 can simply use expression assignment. */
1814 lhs
= gfc_lval_expr_from_sym (sym
);
1815 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1816 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1819 /* Set the stringlength, when needed. */
1820 if (need_len_assign
)
1823 gfc_init_se (&se
, NULL
);
1824 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1826 /* Deferred strings are dealt with in the preceeding. */
1827 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1828 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1830 else if (e
->symtree
->n
.sym
->attr
.function
1831 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
1833 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
1834 tmp
= gfc_class_len_get (tmp
);
1837 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1838 gfc_get_symbol_decl (sym
);
1839 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1840 : gfc_class_len_get (sym
->backend_decl
);
1841 /* Prevent adding a noop len= len. */
1844 gfc_add_modify (&se
.pre
, charlen
,
1845 fold_convert (TREE_TYPE (charlen
), tmp
));
1846 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1847 gfc_finish_block (&se
.post
));
1853 /* Translate a BLOCK construct. This is basically what we would do for a
1857 gfc_trans_block_construct (gfc_code
* code
)
1861 gfc_wrapped_block block
;
1864 gfc_association_list
*ass
;
1866 ns
= code
->ext
.block
.ns
;
1868 sym
= ns
->proc_name
;
1871 /* Process local variables. */
1872 gcc_assert (!sym
->tlink
);
1874 gfc_process_block_locals (ns
);
1876 /* Generate code including exit-label. */
1877 gfc_init_block (&body
);
1878 exit_label
= gfc_build_label_decl (NULL_TREE
);
1879 code
->exit_label
= exit_label
;
1881 finish_oacc_declare (ns
, sym
, true);
1883 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1884 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1886 /* Finish everything. */
1887 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1888 gfc_trans_deferred_vars (sym
, &block
);
1889 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1890 trans_associate_var (ass
->st
->n
.sym
, &block
);
1892 return gfc_finish_wrapped_block (&block
);
1895 /* Translate the simple DO construct in a C-style manner.
1896 This is where the loop variable has integer type and step +-1.
1897 Following code will generate infinite loop in case where TO is INT_MAX
1898 (for +1 step) or INT_MIN (for -1 step)
1900 We translate a do loop from:
1902 DO dovar = from, to, step
1908 [Evaluate loop bounds and step]
1920 This helps the optimizers by avoiding the extra pre-header condition and
1921 we save a register as we just compare the updated IV (not a value in
1925 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1926 tree from
, tree to
, tree step
, tree exit_cond
)
1932 tree saved_dovar
= NULL
;
1936 type
= TREE_TYPE (dovar
);
1937 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
1939 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1941 /* Initialize the DO variable: dovar = from. */
1942 gfc_add_modify_loc (loc
, pblock
, dovar
,
1943 fold_convert (TREE_TYPE (dovar
), from
));
1945 /* Save value for do-tinkering checking. */
1946 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1948 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1949 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1952 /* Cycle and exit statements are implemented with gotos. */
1953 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1954 exit_label
= gfc_build_label_decl (NULL_TREE
);
1956 /* Put the labels where they can be found later. See gfc_trans_do(). */
1957 code
->cycle_label
= cycle_label
;
1958 code
->exit_label
= exit_label
;
1961 gfc_start_block (&body
);
1963 /* Exit the loop if there is an I/O result condition or error. */
1966 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1967 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1969 build_empty_stmt (loc
));
1970 gfc_add_expr_to_block (&body
, tmp
);
1973 /* Evaluate the loop condition. */
1974 if (is_step_positive
)
1975 cond
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, dovar
,
1976 fold_convert (type
, to
));
1978 cond
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, dovar
,
1979 fold_convert (type
, to
));
1981 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1983 /* The loop exit. */
1984 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1985 TREE_USED (exit_label
) = 1;
1986 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1987 cond
, tmp
, build_empty_stmt (loc
));
1988 gfc_add_expr_to_block (&body
, tmp
);
1990 /* Check whether the induction variable is equal to INT_MAX
1991 (respectively to INT_MIN). */
1992 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1994 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
1995 : TYPE_MIN_VALUE (type
);
1997 tmp
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
,
1999 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2000 "Loop iterates infinitely");
2003 /* Main loop body. */
2004 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2005 gfc_add_expr_to_block (&body
, tmp
);
2007 /* Label for cycle statements (if needed). */
2008 if (TREE_USED (cycle_label
))
2010 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2011 gfc_add_expr_to_block (&body
, tmp
);
2014 /* Check whether someone has modified the loop variable. */
2015 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2017 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
,
2018 dovar
, saved_dovar
);
2019 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2020 "Loop variable has been modified");
2023 /* Increment the loop variable. */
2024 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2025 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2027 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2028 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2030 /* Finish the loop body. */
2031 tmp
= gfc_finish_block (&body
);
2032 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2034 gfc_add_expr_to_block (pblock
, tmp
);
2036 /* Add the exit label. */
2037 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2038 gfc_add_expr_to_block (pblock
, tmp
);
2040 return gfc_finish_block (pblock
);
2043 /* Translate the DO construct. This obviously is one of the most
2044 important ones to get right with any compiler, but especially
2047 We special case some loop forms as described in gfc_trans_simple_do.
2048 For other cases we implement them with a separate loop count,
2049 as described in the standard.
2051 We translate a do loop from:
2053 DO dovar = from, to, step
2059 [evaluate loop bounds and step]
2060 empty = (step > 0 ? to < from : to > from);
2061 countm1 = (to - from) / step;
2063 if (empty) goto exit_label;
2071 if (countm1t == 0) goto exit_label;
2075 countm1 is an unsigned integer. It is equal to the loop count minus one,
2076 because the loop count itself can overflow. */
2079 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2083 tree saved_dovar
= NULL
;
2098 gfc_start_block (&block
);
2100 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2102 /* Evaluate all the expressions in the iterator. */
2103 gfc_init_se (&se
, NULL
);
2104 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2105 gfc_add_block_to_block (&block
, &se
.pre
);
2107 type
= TREE_TYPE (dovar
);
2109 gfc_init_se (&se
, NULL
);
2110 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2111 gfc_add_block_to_block (&block
, &se
.pre
);
2112 from
= gfc_evaluate_now (se
.expr
, &block
);
2114 gfc_init_se (&se
, NULL
);
2115 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2116 gfc_add_block_to_block (&block
, &se
.pre
);
2117 to
= gfc_evaluate_now (se
.expr
, &block
);
2119 gfc_init_se (&se
, NULL
);
2120 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2121 gfc_add_block_to_block (&block
, &se
.pre
);
2122 step
= gfc_evaluate_now (se
.expr
, &block
);
2124 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2126 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, step
,
2127 build_zero_cst (type
));
2128 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2129 "DO step value is zero");
2132 /* Special case simple loops. */
2133 if (TREE_CODE (type
) == INTEGER_TYPE
2134 && (integer_onep (step
)
2135 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2136 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2139 if (TREE_CODE (type
) == INTEGER_TYPE
)
2140 utype
= unsigned_type_for (type
);
2142 utype
= unsigned_type_for (gfc_array_index_type
);
2143 countm1
= gfc_create_var (utype
, "countm1");
2145 /* Cycle and exit statements are implemented with gotos. */
2146 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2147 exit_label
= gfc_build_label_decl (NULL_TREE
);
2148 TREE_USED (exit_label
) = 1;
2150 /* Put these labels where they can be found later. */
2151 code
->cycle_label
= cycle_label
;
2152 code
->exit_label
= exit_label
;
2154 /* Initialize the DO variable: dovar = from. */
2155 gfc_add_modify (&block
, dovar
, from
);
2157 /* Save value for do-tinkering checking. */
2158 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2160 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2161 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2164 /* Initialize loop count and jump to exit label if the loop is empty.
2165 This code is executed before we enter the loop body. We generate:
2168 countm1 = (to - from) / step;
2174 countm1 = (from - to) / -step;
2180 if (TREE_CODE (type
) == INTEGER_TYPE
)
2182 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2184 /* The distance from FROM to TO cannot always be represented in a signed
2185 type, thus use unsigned arithmetic, also to avoid any undefined
2187 tou
= fold_convert (utype
, to
);
2188 fromu
= fold_convert (utype
, from
);
2189 stepu
= fold_convert (utype
, step
);
2191 /* For a positive step, when to < from, exit, otherwise compute
2192 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2193 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, to
, from
);
2194 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2195 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2198 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2199 fold_build2 (MODIFY_EXPR
, void_type_node
,
2201 build3_loc (loc
, COND_EXPR
, void_type_node
,
2202 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2203 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2204 exit_label
), NULL_TREE
));
2206 /* For a negative step, when to > from, exit, otherwise compute
2207 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2208 tmp
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, to
, from
);
2209 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2210 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2212 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2213 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2214 fold_build2 (MODIFY_EXPR
, void_type_node
,
2216 build3_loc (loc
, COND_EXPR
, void_type_node
,
2217 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2218 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2219 exit_label
), NULL_TREE
));
2221 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, step
,
2222 build_int_cst (TREE_TYPE (step
), 0));
2223 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2225 gfc_add_expr_to_block (&block
, tmp
);
2231 /* TODO: We could use the same width as the real type.
2232 This would probably cause more problems that it solves
2233 when we implement "long double" types. */
2235 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2236 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2237 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2238 gfc_add_modify (&block
, countm1
, tmp
);
2240 /* We need a special check for empty loops:
2241 empty = (step > 0 ? to < from : to > from); */
2242 pos_step
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, step
,
2243 build_zero_cst (type
));
2244 tmp
= fold_build3_loc (loc
, COND_EXPR
, logical_type_node
, pos_step
,
2245 fold_build2_loc (loc
, LT_EXPR
,
2246 logical_type_node
, to
, from
),
2247 fold_build2_loc (loc
, GT_EXPR
,
2248 logical_type_node
, to
, from
));
2249 /* If the loop is empty, go directly to the exit label. */
2250 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2251 build1_v (GOTO_EXPR
, exit_label
),
2252 build_empty_stmt (input_location
));
2253 gfc_add_expr_to_block (&block
, tmp
);
2257 gfc_start_block (&body
);
2259 /* Main loop body. */
2260 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2261 gfc_add_expr_to_block (&body
, tmp
);
2263 /* Label for cycle statements (if needed). */
2264 if (TREE_USED (cycle_label
))
2266 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2267 gfc_add_expr_to_block (&body
, tmp
);
2270 /* Check whether someone has modified the loop variable. */
2271 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2273 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
, dovar
,
2275 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2276 "Loop variable has been modified");
2279 /* Exit the loop if there is an I/O result condition or error. */
2282 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2283 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2285 build_empty_stmt (input_location
));
2286 gfc_add_expr_to_block (&body
, tmp
);
2289 /* Increment the loop variable. */
2290 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2291 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2293 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2294 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2296 /* Initialize countm1t. */
2297 tree countm1t
= gfc_create_var (utype
, "countm1t");
2298 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2300 /* Decrement the loop count. */
2301 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2302 build_int_cst (utype
, 1));
2303 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2305 /* End with the loop condition. Loop until countm1t == 0. */
2306 cond
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
, countm1t
,
2307 build_int_cst (utype
, 0));
2308 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2309 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2310 cond
, tmp
, build_empty_stmt (loc
));
2311 gfc_add_expr_to_block (&body
, tmp
);
2313 /* End of loop body. */
2314 tmp
= gfc_finish_block (&body
);
2316 /* The for loop itself. */
2317 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2318 gfc_add_expr_to_block (&block
, tmp
);
2320 /* Add the exit label. */
2321 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2322 gfc_add_expr_to_block (&block
, tmp
);
2324 return gfc_finish_block (&block
);
2328 /* Translate the DO WHILE construct.
2341 if (! cond) goto exit_label;
2347 Because the evaluation of the exit condition `cond' may have side
2348 effects, we can't do much for empty loop bodies. The backend optimizers
2349 should be smart enough to eliminate any dead loops. */
2352 gfc_trans_do_while (gfc_code
* code
)
2360 /* Everything we build here is part of the loop body. */
2361 gfc_start_block (&block
);
2363 /* Cycle and exit statements are implemented with gotos. */
2364 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2365 exit_label
= gfc_build_label_decl (NULL_TREE
);
2367 /* Put the labels where they can be found later. See gfc_trans_do(). */
2368 code
->cycle_label
= cycle_label
;
2369 code
->exit_label
= exit_label
;
2371 /* Create a GIMPLE version of the exit condition. */
2372 gfc_init_se (&cond
, NULL
);
2373 gfc_conv_expr_val (&cond
, code
->expr1
);
2374 gfc_add_block_to_block (&block
, &cond
.pre
);
2375 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2376 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2378 /* Build "IF (! cond) GOTO exit_label". */
2379 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2380 TREE_USED (exit_label
) = 1;
2381 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2382 void_type_node
, cond
.expr
, tmp
,
2383 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2384 gfc_add_expr_to_block (&block
, tmp
);
2386 /* The main body of the loop. */
2387 tmp
= gfc_trans_code (code
->block
->next
);
2388 gfc_add_expr_to_block (&block
, tmp
);
2390 /* Label for cycle statements (if needed). */
2391 if (TREE_USED (cycle_label
))
2393 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2394 gfc_add_expr_to_block (&block
, tmp
);
2397 /* End of loop body. */
2398 tmp
= gfc_finish_block (&block
);
2400 gfc_init_block (&block
);
2401 /* Build the loop. */
2402 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2403 void_type_node
, tmp
);
2404 gfc_add_expr_to_block (&block
, tmp
);
2406 /* Add the exit label. */
2407 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2408 gfc_add_expr_to_block (&block
, tmp
);
2410 return gfc_finish_block (&block
);
2414 /* Deal with the particular case of SELECT_TYPE, where the vtable
2415 addresses are used for the selection. Since these are not sorted,
2416 the selection has to be made by a series of if statements. */
2419 gfc_trans_select_type_cases (gfc_code
* code
)
2433 gfc_start_block (&block
);
2435 /* Calculate the switch expression. */
2436 gfc_init_se (&se
, NULL
);
2437 gfc_conv_expr_val (&se
, code
->expr1
);
2438 gfc_add_block_to_block (&block
, &se
.pre
);
2440 /* Generate an expression for the selector hash value, for
2441 use to resolve character cases. */
2442 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2443 gfc_add_hash_component (e
);
2445 TREE_USED (code
->exit_label
) = 0;
2448 for (c
= code
->block
; c
; c
= c
->block
)
2450 cp
= c
->ext
.block
.case_list
;
2452 /* Assume it's the default case. */
2457 /* Put the default case at the end. */
2458 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2461 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2462 || cp
->ts
.type
== BT_DERIVED
))
2464 gfc_init_se (&cse
, NULL
);
2465 gfc_conv_expr_val (&cse
, cp
->low
);
2466 gfc_add_block_to_block (&block
, &cse
.pre
);
2469 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2471 gcc_assert (cp
->high
);
2472 gfc_init_se (&cse
, NULL
);
2473 gfc_conv_expr_val (&cse
, cp
->high
);
2474 gfc_add_block_to_block (&block
, &cse
.pre
);
2478 gfc_init_block (&body
);
2480 /* Add the statements for this case. */
2481 tmp
= gfc_trans_code (c
->next
);
2482 gfc_add_expr_to_block (&body
, tmp
);
2484 /* Break to the end of the SELECT TYPE construct. The default
2485 case just falls through. */
2488 TREE_USED (code
->exit_label
) = 1;
2489 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2490 gfc_add_expr_to_block (&body
, tmp
);
2493 tmp
= gfc_finish_block (&body
);
2495 if (low
!= NULL_TREE
)
2497 /* Compare vtable pointers. */
2498 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2499 TREE_TYPE (se
.expr
), se
.expr
, low
);
2500 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2502 build_empty_stmt (input_location
));
2504 else if (high
!= NULL_TREE
)
2506 /* Compare hash values for character cases. */
2507 gfc_init_se (&cse
, NULL
);
2508 gfc_conv_expr_val (&cse
, e
);
2509 gfc_add_block_to_block (&block
, &cse
.pre
);
2511 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2512 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2513 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2515 build_empty_stmt (input_location
));
2518 gfc_add_expr_to_block (&block
, tmp
);
2529 return gfc_finish_block (&block
);
2533 /* Translate the SELECT CASE construct for INTEGER case expressions,
2534 without killing all potential optimizations. The problem is that
2535 Fortran allows unbounded cases, but the back-end does not, so we
2536 need to intercept those before we enter the equivalent SWITCH_EXPR
2539 For example, we translate this,
2542 CASE (:100,101,105:115)
2552 to the GENERIC equivalent,
2556 case (minimum value for typeof(expr) ... 100:
2562 case 200 ... (maximum value for typeof(expr):
2579 gfc_trans_integer_select (gfc_code
* code
)
2589 gfc_start_block (&block
);
2591 /* Calculate the switch expression. */
2592 gfc_init_se (&se
, NULL
);
2593 gfc_conv_expr_val (&se
, code
->expr1
);
2594 gfc_add_block_to_block (&block
, &se
.pre
);
2596 end_label
= gfc_build_label_decl (NULL_TREE
);
2598 gfc_init_block (&body
);
2600 for (c
= code
->block
; c
; c
= c
->block
)
2602 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2607 /* Assume it's the default case. */
2608 low
= high
= NULL_TREE
;
2612 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2615 /* If there's only a lower bound, set the high bound to the
2616 maximum value of the case expression. */
2618 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2623 /* Three cases are possible here:
2625 1) There is no lower bound, e.g. CASE (:N).
2626 2) There is a lower bound .NE. high bound, that is
2627 a case range, e.g. CASE (N:M) where M>N (we make
2628 sure that M>N during type resolution).
2629 3) There is a lower bound, and it has the same value
2630 as the high bound, e.g. CASE (N:N). This is our
2631 internal representation of CASE(N).
2633 In the first and second case, we need to set a value for
2634 high. In the third case, we don't because the GCC middle
2635 end represents a single case value by just letting high be
2636 a NULL_TREE. We can't do that because we need to be able
2637 to represent unbounded cases. */
2640 || (mpz_cmp (cp
->low
->value
.integer
,
2641 cp
->high
->value
.integer
) != 0))
2642 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2645 /* Unbounded case. */
2647 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2650 /* Build a label. */
2651 label
= gfc_build_label_decl (NULL_TREE
);
2653 /* Add this case label.
2654 Add parameter 'label', make it match GCC backend. */
2655 tmp
= build_case_label (low
, high
, label
);
2656 gfc_add_expr_to_block (&body
, tmp
);
2659 /* Add the statements for this case. */
2660 tmp
= gfc_trans_code (c
->next
);
2661 gfc_add_expr_to_block (&body
, tmp
);
2663 /* Break to the end of the construct. */
2664 tmp
= build1_v (GOTO_EXPR
, end_label
);
2665 gfc_add_expr_to_block (&body
, tmp
);
2668 tmp
= gfc_finish_block (&body
);
2669 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, se
.expr
, tmp
);
2670 gfc_add_expr_to_block (&block
, tmp
);
2672 tmp
= build1_v (LABEL_EXPR
, end_label
);
2673 gfc_add_expr_to_block (&block
, tmp
);
2675 return gfc_finish_block (&block
);
2679 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2681 There are only two cases possible here, even though the standard
2682 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2683 .FALSE., and DEFAULT.
2685 We never generate more than two blocks here. Instead, we always
2686 try to eliminate the DEFAULT case. This way, we can translate this
2687 kind of SELECT construct to a simple
2691 expression in GENERIC. */
2694 gfc_trans_logical_select (gfc_code
* code
)
2697 gfc_code
*t
, *f
, *d
;
2702 /* Assume we don't have any cases at all. */
2705 /* Now see which ones we actually do have. We can have at most two
2706 cases in a single case list: one for .TRUE. and one for .FALSE.
2707 The default case is always separate. If the cases for .TRUE. and
2708 .FALSE. are in the same case list, the block for that case list
2709 always executed, and we don't generate code a COND_EXPR. */
2710 for (c
= code
->block
; c
; c
= c
->block
)
2712 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2716 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2718 else /* if (cp->value.logical != 0), thus .TRUE. */
2726 /* Start a new block. */
2727 gfc_start_block (&block
);
2729 /* Calculate the switch expression. We always need to do this
2730 because it may have side effects. */
2731 gfc_init_se (&se
, NULL
);
2732 gfc_conv_expr_val (&se
, code
->expr1
);
2733 gfc_add_block_to_block (&block
, &se
.pre
);
2735 if (t
== f
&& t
!= NULL
)
2737 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2738 translate the code for these cases, append it to the current
2740 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2744 tree true_tree
, false_tree
, stmt
;
2746 true_tree
= build_empty_stmt (input_location
);
2747 false_tree
= build_empty_stmt (input_location
);
2749 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2750 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2751 make the missing case the default case. */
2752 if (t
!= NULL
&& f
!= NULL
)
2762 /* Translate the code for each of these blocks, and append it to
2763 the current block. */
2765 true_tree
= gfc_trans_code (t
->next
);
2768 false_tree
= gfc_trans_code (f
->next
);
2770 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2771 se
.expr
, true_tree
, false_tree
);
2772 gfc_add_expr_to_block (&block
, stmt
);
2775 return gfc_finish_block (&block
);
2779 /* The jump table types are stored in static variables to avoid
2780 constructing them from scratch every single time. */
2781 static GTY(()) tree select_struct
[2];
2783 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2784 Instead of generating compares and jumps, it is far simpler to
2785 generate a data structure describing the cases in order and call a
2786 library subroutine that locates the right case.
2787 This is particularly true because this is the only case where we
2788 might have to dispose of a temporary.
2789 The library subroutine returns a pointer to jump to or NULL if no
2790 branches are to be taken. */
2793 gfc_trans_character_select (gfc_code
*code
)
2795 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2796 stmtblock_t block
, body
;
2801 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2803 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2805 /* The jump table types are stored in static variables to avoid
2806 constructing them from scratch every single time. */
2807 static tree ss_string1
[2], ss_string1_len
[2];
2808 static tree ss_string2
[2], ss_string2_len
[2];
2809 static tree ss_target
[2];
2811 cp
= code
->block
->ext
.block
.case_list
;
2812 while (cp
->left
!= NULL
)
2815 /* Generate the body */
2816 gfc_start_block (&block
);
2817 gfc_init_se (&expr1se
, NULL
);
2818 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2820 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2822 end_label
= gfc_build_label_decl (NULL_TREE
);
2824 gfc_init_block (&body
);
2826 /* Attempt to optimize length 1 selects. */
2827 if (integer_onep (expr1se
.string_length
))
2829 for (d
= cp
; d
; d
= d
->right
)
2834 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2835 && d
->low
->ts
.type
== BT_CHARACTER
);
2836 if (d
->low
->value
.character
.length
> 1)
2838 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2839 if (d
->low
->value
.character
.string
[i
] != ' ')
2841 if (i
!= d
->low
->value
.character
.length
)
2843 if (optimize
&& d
->high
&& i
== 1)
2845 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2846 && d
->high
->ts
.type
== BT_CHARACTER
);
2847 if (d
->high
->value
.character
.length
> 1
2848 && (d
->low
->value
.character
.string
[0]
2849 == d
->high
->value
.character
.string
[0])
2850 && d
->high
->value
.character
.string
[1] != ' '
2851 && ((d
->low
->value
.character
.string
[1] < ' ')
2852 == (d
->high
->value
.character
.string
[1]
2862 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2863 && d
->high
->ts
.type
== BT_CHARACTER
);
2864 if (d
->high
->value
.character
.length
> 1)
2866 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2867 if (d
->high
->value
.character
.string
[i
] != ' ')
2869 if (i
!= d
->high
->value
.character
.length
)
2876 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2878 for (c
= code
->block
; c
; c
= c
->block
)
2880 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2886 /* Assume it's the default case. */
2887 low
= high
= NULL_TREE
;
2891 /* CASE ('ab') or CASE ('ab':'az') will never match
2892 any length 1 character. */
2893 if (cp
->low
->value
.character
.length
> 1
2894 && cp
->low
->value
.character
.string
[1] != ' ')
2897 if (cp
->low
->value
.character
.length
> 0)
2898 r
= cp
->low
->value
.character
.string
[0];
2901 low
= build_int_cst (ctype
, r
);
2903 /* If there's only a lower bound, set the high bound
2904 to the maximum value of the case expression. */
2906 high
= TYPE_MAX_VALUE (ctype
);
2912 || (cp
->low
->value
.character
.string
[0]
2913 != cp
->high
->value
.character
.string
[0]))
2915 if (cp
->high
->value
.character
.length
> 0)
2916 r
= cp
->high
->value
.character
.string
[0];
2919 high
= build_int_cst (ctype
, r
);
2922 /* Unbounded case. */
2924 low
= TYPE_MIN_VALUE (ctype
);
2927 /* Build a label. */
2928 label
= gfc_build_label_decl (NULL_TREE
);
2930 /* Add this case label.
2931 Add parameter 'label', make it match GCC backend. */
2932 tmp
= build_case_label (low
, high
, label
);
2933 gfc_add_expr_to_block (&body
, tmp
);
2936 /* Add the statements for this case. */
2937 tmp
= gfc_trans_code (c
->next
);
2938 gfc_add_expr_to_block (&body
, tmp
);
2940 /* Break to the end of the construct. */
2941 tmp
= build1_v (GOTO_EXPR
, end_label
);
2942 gfc_add_expr_to_block (&body
, tmp
);
2945 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2947 code
->expr1
->ts
.kind
);
2948 case_num
= gfc_create_var (ctype
, "case_num");
2949 gfc_add_modify (&block
, case_num
, tmp
);
2951 gfc_add_block_to_block (&block
, &expr1se
.post
);
2953 tmp
= gfc_finish_block (&body
);
2954 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2956 gfc_add_expr_to_block (&block
, tmp
);
2958 tmp
= build1_v (LABEL_EXPR
, end_label
);
2959 gfc_add_expr_to_block (&block
, tmp
);
2961 return gfc_finish_block (&block
);
2965 if (code
->expr1
->ts
.kind
== 1)
2967 else if (code
->expr1
->ts
.kind
== 4)
2972 if (select_struct
[k
] == NULL
)
2975 select_struct
[k
] = make_node (RECORD_TYPE
);
2977 if (code
->expr1
->ts
.kind
== 1)
2978 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2979 else if (code
->expr1
->ts
.kind
== 4)
2980 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2985 #define ADD_FIELD(NAME, TYPE) \
2986 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2987 get_identifier (stringize(NAME)), \
2991 ADD_FIELD (string1
, pchartype
);
2992 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2994 ADD_FIELD (string2
, pchartype
);
2995 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2997 ADD_FIELD (target
, integer_type_node
);
3000 gfc_finish_type (select_struct
[k
]);
3004 for (d
= cp
; d
; d
= d
->right
)
3007 for (c
= code
->block
; c
; c
= c
->block
)
3009 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
3011 label
= gfc_build_label_decl (NULL_TREE
);
3012 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
3014 : build_int_cst (integer_type_node
, d
->n
),
3016 gfc_add_expr_to_block (&body
, tmp
);
3019 tmp
= gfc_trans_code (c
->next
);
3020 gfc_add_expr_to_block (&body
, tmp
);
3022 tmp
= build1_v (GOTO_EXPR
, end_label
);
3023 gfc_add_expr_to_block (&body
, tmp
);
3026 /* Generate the structure describing the branches */
3027 for (d
= cp
; d
; d
= d
->right
)
3029 vec
<constructor_elt
, va_gc
> *node
= NULL
;
3031 gfc_init_se (&se
, NULL
);
3035 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
3036 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
3040 gfc_conv_expr_reference (&se
, d
->low
);
3042 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
3043 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
3046 if (d
->high
== NULL
)
3048 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
3049 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
3053 gfc_init_se (&se
, NULL
);
3054 gfc_conv_expr_reference (&se
, d
->high
);
3056 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
3057 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
3060 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
3061 build_int_cst (integer_type_node
, d
->n
));
3063 tmp
= build_constructor (select_struct
[k
], node
);
3064 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
3067 type
= build_array_type (select_struct
[k
],
3068 build_index_type (size_int (n
-1)));
3070 init
= build_constructor (type
, inits
);
3071 TREE_CONSTANT (init
) = 1;
3072 TREE_STATIC (init
) = 1;
3073 /* Create a static variable to hold the jump table. */
3074 tmp
= gfc_create_var (type
, "jumptable");
3075 TREE_CONSTANT (tmp
) = 1;
3076 TREE_STATIC (tmp
) = 1;
3077 TREE_READONLY (tmp
) = 1;
3078 DECL_INITIAL (tmp
) = init
;
3081 /* Build the library call */
3082 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3084 if (code
->expr1
->ts
.kind
== 1)
3085 fndecl
= gfor_fndecl_select_string
;
3086 else if (code
->expr1
->ts
.kind
== 4)
3087 fndecl
= gfor_fndecl_select_string_char4
;
3091 tmp
= build_call_expr_loc (input_location
,
3093 build_int_cst (gfc_charlen_type_node
, n
),
3094 expr1se
.expr
, expr1se
.string_length
);
3095 case_num
= gfc_create_var (integer_type_node
, "case_num");
3096 gfc_add_modify (&block
, case_num
, tmp
);
3098 gfc_add_block_to_block (&block
, &expr1se
.post
);
3100 tmp
= gfc_finish_block (&body
);
3101 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3103 gfc_add_expr_to_block (&block
, tmp
);
3105 tmp
= build1_v (LABEL_EXPR
, end_label
);
3106 gfc_add_expr_to_block (&block
, tmp
);
3108 return gfc_finish_block (&block
);
3112 /* Translate the three variants of the SELECT CASE construct.
3114 SELECT CASEs with INTEGER case expressions can be translated to an
3115 equivalent GENERIC switch statement, and for LOGICAL case
3116 expressions we build one or two if-else compares.
3118 SELECT CASEs with CHARACTER case expressions are a whole different
3119 story, because they don't exist in GENERIC. So we sort them and
3120 do a binary search at runtime.
3122 Fortran has no BREAK statement, and it does not allow jumps from
3123 one case block to another. That makes things a lot easier for
3127 gfc_trans_select (gfc_code
* code
)
3133 gcc_assert (code
&& code
->expr1
);
3134 gfc_init_block (&block
);
3136 /* Build the exit label and hang it in. */
3137 exit_label
= gfc_build_label_decl (NULL_TREE
);
3138 code
->exit_label
= exit_label
;
3140 /* Empty SELECT constructs are legal. */
3141 if (code
->block
== NULL
)
3142 body
= build_empty_stmt (input_location
);
3144 /* Select the correct translation function. */
3146 switch (code
->expr1
->ts
.type
)
3149 body
= gfc_trans_logical_select (code
);
3153 body
= gfc_trans_integer_select (code
);
3157 body
= gfc_trans_character_select (code
);
3161 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3165 /* Build everything together. */
3166 gfc_add_expr_to_block (&block
, body
);
3167 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3169 return gfc_finish_block (&block
);
3173 gfc_trans_select_type (gfc_code
* code
)
3179 gcc_assert (code
&& code
->expr1
);
3180 gfc_init_block (&block
);
3182 /* Build the exit label and hang it in. */
3183 exit_label
= gfc_build_label_decl (NULL_TREE
);
3184 code
->exit_label
= exit_label
;
3186 /* Empty SELECT constructs are legal. */
3187 if (code
->block
== NULL
)
3188 body
= build_empty_stmt (input_location
);
3190 body
= gfc_trans_select_type_cases (code
);
3192 /* Build everything together. */
3193 gfc_add_expr_to_block (&block
, body
);
3195 if (TREE_USED (exit_label
))
3196 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3198 return gfc_finish_block (&block
);
3202 /* Traversal function to substitute a replacement symtree if the symbol
3203 in the expression is the same as that passed. f == 2 signals that
3204 that variable itself is not to be checked - only the references.
3205 This group of functions is used when the variable expression in a
3206 FORALL assignment has internal references. For example:
3207 FORALL (i = 1:4) p(p(i)) = i
3208 The only recourse here is to store a copy of 'p' for the index
3211 static gfc_symtree
*new_symtree
;
3212 static gfc_symtree
*old_symtree
;
3215 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3217 if (expr
->expr_type
!= EXPR_VARIABLE
)
3222 else if (expr
->symtree
->n
.sym
== sym
)
3223 expr
->symtree
= new_symtree
;
3229 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3231 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3235 forall_restore (gfc_expr
*expr
,
3236 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3237 int *f ATTRIBUTE_UNUSED
)
3239 if (expr
->expr_type
!= EXPR_VARIABLE
)
3242 if (expr
->symtree
== new_symtree
)
3243 expr
->symtree
= old_symtree
;
3249 forall_restore_symtree (gfc_expr
*e
)
3251 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3255 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3260 gfc_symbol
*new_sym
;
3261 gfc_symbol
*old_sym
;
3265 /* Build a copy of the lvalue. */
3266 old_symtree
= c
->expr1
->symtree
;
3267 old_sym
= old_symtree
->n
.sym
;
3268 e
= gfc_lval_expr_from_sym (old_sym
);
3269 if (old_sym
->attr
.dimension
)
3271 gfc_init_se (&tse
, NULL
);
3272 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3273 gfc_add_block_to_block (pre
, &tse
.pre
);
3274 gfc_add_block_to_block (post
, &tse
.post
);
3275 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3277 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3279 /* Use the variable offset for the temporary. */
3280 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3281 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3286 gfc_init_se (&tse
, NULL
);
3287 gfc_init_se (&rse
, NULL
);
3288 gfc_conv_expr (&rse
, e
);
3289 if (e
->ts
.type
== BT_CHARACTER
)
3291 tse
.string_length
= rse
.string_length
;
3292 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3294 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3296 gfc_add_block_to_block (pre
, &tse
.pre
);
3297 gfc_add_block_to_block (post
, &tse
.post
);
3301 tmp
= gfc_typenode_for_spec (&e
->ts
);
3302 tse
.expr
= gfc_create_var (tmp
, "temp");
3305 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3306 e
->expr_type
== EXPR_VARIABLE
, false);
3307 gfc_add_expr_to_block (pre
, tmp
);
3311 /* Create a new symbol to represent the lvalue. */
3312 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3313 new_sym
->ts
= old_sym
->ts
;
3314 new_sym
->attr
.referenced
= 1;
3315 new_sym
->attr
.temporary
= 1;
3316 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3317 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3319 /* Use the temporary as the backend_decl. */
3320 new_sym
->backend_decl
= tse
.expr
;
3322 /* Create a fake symtree for it. */
3324 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3325 new_symtree
->n
.sym
= new_sym
;
3326 gcc_assert (new_symtree
== root
);
3328 /* Go through the expression reference replacing the old_symtree
3330 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3332 /* Now we have made this temporary, we might as well use it for
3333 the right hand side. */
3334 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3338 /* Handles dependencies in forall assignments. */
3340 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3347 lsym
= c
->expr1
->symtree
->n
.sym
;
3348 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3350 /* Now check for dependencies within the 'variable'
3351 expression itself. These are treated by making a complete
3352 copy of variable and changing all the references to it
3353 point to the copy instead. Note that the shallow copy of
3354 the variable will not suffice for derived types with
3355 pointer components. We therefore leave these to their
3357 if (lsym
->ts
.type
== BT_DERIVED
3358 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3362 if (find_forall_index (c
->expr1
, lsym
, 2))
3364 forall_make_variable_temp (c
, pre
, post
);
3368 /* Substrings with dependencies are treated in the same
3370 if (c
->expr1
->ts
.type
== BT_CHARACTER
3372 && c
->expr2
->expr_type
== EXPR_VARIABLE
3373 && lsym
== c
->expr2
->symtree
->n
.sym
)
3375 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3376 if (lref
->type
== REF_SUBSTRING
)
3378 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3379 if (rref
->type
== REF_SUBSTRING
)
3383 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3385 forall_make_variable_temp (c
, pre
, post
);
3394 cleanup_forall_symtrees (gfc_code
*c
)
3396 forall_restore_symtree (c
->expr1
);
3397 forall_restore_symtree (c
->expr2
);
3398 free (new_symtree
->n
.sym
);
3403 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3404 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3405 indicates whether we should generate code to test the FORALLs mask
3406 array. OUTER is the loop header to be used for initializing mask
3409 The generated loop format is:
3410 count = (end - start + step) / step
3423 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3424 int mask_flag
, stmtblock_t
*outer
)
3432 tree var
, start
, end
, step
;
3435 /* Initialize the mask index outside the FORALL nest. */
3436 if (mask_flag
&& forall_tmp
->mask
)
3437 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3439 iter
= forall_tmp
->this_loop
;
3440 nvar
= forall_tmp
->nvar
;
3441 for (n
= 0; n
< nvar
; n
++)
3444 start
= iter
->start
;
3448 exit_label
= gfc_build_label_decl (NULL_TREE
);
3449 TREE_USED (exit_label
) = 1;
3451 /* The loop counter. */
3452 count
= gfc_create_var (TREE_TYPE (var
), "count");
3454 /* The body of the loop. */
3455 gfc_init_block (&block
);
3457 /* The exit condition. */
3458 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
3459 count
, build_int_cst (TREE_TYPE (count
), 0));
3460 if (forall_tmp
->do_concurrent
)
3461 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3462 build_int_cst (integer_type_node
,
3463 annot_expr_parallel_kind
),
3466 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3467 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3468 cond
, tmp
, build_empty_stmt (input_location
));
3469 gfc_add_expr_to_block (&block
, tmp
);
3471 /* The main loop body. */
3472 gfc_add_expr_to_block (&block
, body
);
3474 /* Increment the loop variable. */
3475 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3477 gfc_add_modify (&block
, var
, tmp
);
3479 /* Advance to the next mask element. Only do this for the
3481 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3483 tree maskindex
= forall_tmp
->maskindex
;
3484 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3485 maskindex
, gfc_index_one_node
);
3486 gfc_add_modify (&block
, maskindex
, tmp
);
3489 /* Decrement the loop counter. */
3490 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3491 build_int_cst (TREE_TYPE (var
), 1));
3492 gfc_add_modify (&block
, count
, tmp
);
3494 body
= gfc_finish_block (&block
);
3496 /* Loop var initialization. */
3497 gfc_init_block (&block
);
3498 gfc_add_modify (&block
, var
, start
);
3501 /* Initialize the loop counter. */
3502 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3504 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3506 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3508 gfc_add_modify (&block
, count
, tmp
);
3510 /* The loop expression. */
3511 tmp
= build1_v (LOOP_EXPR
, body
);
3512 gfc_add_expr_to_block (&block
, tmp
);
3514 /* The exit label. */
3515 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3516 gfc_add_expr_to_block (&block
, tmp
);
3518 body
= gfc_finish_block (&block
);
3525 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3526 is nonzero, the body is controlled by all masks in the forall nest.
3527 Otherwise, the innermost loop is not controlled by it's mask. This
3528 is used for initializing that mask. */
3531 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3536 forall_info
*forall_tmp
;
3537 tree mask
, maskindex
;
3539 gfc_start_block (&header
);
3541 forall_tmp
= nested_forall_info
;
3542 while (forall_tmp
!= NULL
)
3544 /* Generate body with masks' control. */
3547 mask
= forall_tmp
->mask
;
3548 maskindex
= forall_tmp
->maskindex
;
3550 /* If a mask was specified make the assignment conditional. */
3553 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3554 body
= build3_v (COND_EXPR
, tmp
, body
,
3555 build_empty_stmt (input_location
));
3558 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3559 forall_tmp
= forall_tmp
->prev_nest
;
3563 gfc_add_expr_to_block (&header
, body
);
3564 return gfc_finish_block (&header
);
3568 /* Allocate data for holding a temporary array. Returns either a local
3569 temporary array or a pointer variable. */
3572 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3579 if (INTEGER_CST_P (size
))
3580 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3581 size
, gfc_index_one_node
);
3585 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3586 type
= build_array_type (elem_type
, type
);
3587 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3589 tmpvar
= gfc_create_var (type
, "temp");
3594 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3595 *pdata
= convert (pvoid_type_node
, tmpvar
);
3597 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3598 gfc_add_modify (pblock
, tmpvar
, tmp
);
3604 /* Generate codes to copy the temporary to the actual lhs. */
3607 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3609 gfc_ss
*lss
, gfc_ss
*rss
,
3610 tree wheremask
, bool invert
)
3612 stmtblock_t block
, body1
;
3619 (void) rss
; /* TODO: unused. */
3621 gfc_start_block (&block
);
3623 gfc_init_se (&rse
, NULL
);
3624 gfc_init_se (&lse
, NULL
);
3626 if (lss
== gfc_ss_terminator
)
3628 gfc_init_block (&body1
);
3629 gfc_conv_expr (&lse
, expr
);
3630 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3634 /* Initialize the loop. */
3635 gfc_init_loopinfo (&loop
);
3637 /* We may need LSS to determine the shape of the expression. */
3638 gfc_add_ss_to_loop (&loop
, lss
);
3640 gfc_conv_ss_startstride (&loop
);
3641 gfc_conv_loop_setup (&loop
, &expr
->where
);
3643 gfc_mark_ss_chain_used (lss
, 1);
3644 /* Start the loop body. */
3645 gfc_start_scalarized_body (&loop
, &body1
);
3647 /* Translate the expression. */
3648 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3650 gfc_conv_expr (&lse
, expr
);
3652 /* Form the expression of the temporary. */
3653 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3656 /* Use the scalar assignment. */
3657 rse
.string_length
= lse
.string_length
;
3658 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
3659 expr
->expr_type
== EXPR_VARIABLE
, false);
3661 /* Form the mask expression according to the mask tree list. */
3664 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3666 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3667 TREE_TYPE (wheremaskexpr
),
3669 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3671 build_empty_stmt (input_location
));
3674 gfc_add_expr_to_block (&body1
, tmp
);
3676 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3677 count1
, gfc_index_one_node
);
3678 gfc_add_modify (&body1
, count1
, tmp
);
3680 if (lss
== gfc_ss_terminator
)
3681 gfc_add_block_to_block (&block
, &body1
);
3684 /* Increment count3. */
3687 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3688 gfc_array_index_type
,
3689 count3
, gfc_index_one_node
);
3690 gfc_add_modify (&body1
, count3
, tmp
);
3693 /* Generate the copying loops. */
3694 gfc_trans_scalarizing_loops (&loop
, &body1
);
3696 gfc_add_block_to_block (&block
, &loop
.pre
);
3697 gfc_add_block_to_block (&block
, &loop
.post
);
3699 gfc_cleanup_loop (&loop
);
3700 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3701 as tree nodes in SS may not be valid in different scope. */
3704 tmp
= gfc_finish_block (&block
);
3709 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3710 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3711 and should not be freed. WHEREMASK is the conditional execution mask
3712 whose sense may be inverted by INVERT. */
3715 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3716 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3717 tree wheremask
, bool invert
)
3719 stmtblock_t block
, body1
;
3726 gfc_start_block (&block
);
3728 gfc_init_se (&rse
, NULL
);
3729 gfc_init_se (&lse
, NULL
);
3731 if (lss
== gfc_ss_terminator
)
3733 gfc_init_block (&body1
);
3734 gfc_conv_expr (&rse
, expr2
);
3735 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3739 /* Initialize the loop. */
3740 gfc_init_loopinfo (&loop
);
3742 /* We may need LSS to determine the shape of the expression. */
3743 gfc_add_ss_to_loop (&loop
, lss
);
3744 gfc_add_ss_to_loop (&loop
, rss
);
3746 gfc_conv_ss_startstride (&loop
);
3747 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3749 gfc_mark_ss_chain_used (rss
, 1);
3750 /* Start the loop body. */
3751 gfc_start_scalarized_body (&loop
, &body1
);
3753 /* Translate the expression. */
3754 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3756 gfc_conv_expr (&rse
, expr2
);
3758 /* Form the expression of the temporary. */
3759 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3762 /* Use the scalar assignment. */
3763 lse
.string_length
= rse
.string_length
;
3764 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3765 expr2
->expr_type
== EXPR_VARIABLE
, false);
3767 /* Form the mask expression according to the mask tree list. */
3770 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3772 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3773 TREE_TYPE (wheremaskexpr
),
3775 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3777 build_empty_stmt (input_location
));
3780 gfc_add_expr_to_block (&body1
, tmp
);
3782 if (lss
== gfc_ss_terminator
)
3784 gfc_add_block_to_block (&block
, &body1
);
3786 /* Increment count1. */
3787 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3788 count1
, gfc_index_one_node
);
3789 gfc_add_modify (&block
, count1
, tmp
);
3793 /* Increment count1. */
3794 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3795 count1
, gfc_index_one_node
);
3796 gfc_add_modify (&body1
, count1
, tmp
);
3798 /* Increment count3. */
3801 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3802 gfc_array_index_type
,
3803 count3
, gfc_index_one_node
);
3804 gfc_add_modify (&body1
, count3
, tmp
);
3807 /* Generate the copying loops. */
3808 gfc_trans_scalarizing_loops (&loop
, &body1
);
3810 gfc_add_block_to_block (&block
, &loop
.pre
);
3811 gfc_add_block_to_block (&block
, &loop
.post
);
3813 gfc_cleanup_loop (&loop
);
3814 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3815 as tree nodes in SS may not be valid in different scope. */
3818 tmp
= gfc_finish_block (&block
);
3823 /* Calculate the size of temporary needed in the assignment inside forall.
3824 LSS and RSS are filled in this function. */
3827 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3828 stmtblock_t
* pblock
,
3829 gfc_ss
**lss
, gfc_ss
**rss
)
3837 *lss
= gfc_walk_expr (expr1
);
3840 size
= gfc_index_one_node
;
3841 if (*lss
!= gfc_ss_terminator
)
3843 gfc_init_loopinfo (&loop
);
3845 /* Walk the RHS of the expression. */
3846 *rss
= gfc_walk_expr (expr2
);
3847 if (*rss
== gfc_ss_terminator
)
3848 /* The rhs is scalar. Add a ss for the expression. */
3849 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3851 /* Associate the SS with the loop. */
3852 gfc_add_ss_to_loop (&loop
, *lss
);
3853 /* We don't actually need to add the rhs at this point, but it might
3854 make guessing the loop bounds a bit easier. */
3855 gfc_add_ss_to_loop (&loop
, *rss
);
3857 /* We only want the shape of the expression, not rest of the junk
3858 generated by the scalarizer. */
3859 loop
.array_parameter
= 1;
3861 /* Calculate the bounds of the scalarization. */
3862 save_flag
= gfc_option
.rtcheck
;
3863 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3864 gfc_conv_ss_startstride (&loop
);
3865 gfc_option
.rtcheck
= save_flag
;
3866 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3868 /* Figure out how many elements we need. */
3869 for (i
= 0; i
< loop
.dimen
; i
++)
3871 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3872 gfc_array_index_type
,
3873 gfc_index_one_node
, loop
.from
[i
]);
3874 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3875 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3876 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3877 gfc_array_index_type
, size
, tmp
);
3879 gfc_add_block_to_block (pblock
, &loop
.pre
);
3880 size
= gfc_evaluate_now (size
, pblock
);
3881 gfc_add_block_to_block (pblock
, &loop
.post
);
3883 /* TODO: write a function that cleans up a loopinfo without freeing
3884 the SS chains. Currently a NOP. */
3891 /* Calculate the overall iterator number of the nested forall construct.
3892 This routine actually calculates the number of times the body of the
3893 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3894 that by the expression INNER_SIZE. The BLOCK argument specifies the
3895 block in which to calculate the result, and the optional INNER_SIZE_BODY
3896 argument contains any statements that need to executed (inside the loop)
3897 to initialize or calculate INNER_SIZE. */
3900 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3901 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3903 forall_info
*forall_tmp
= nested_forall_info
;
3907 /* We can eliminate the innermost unconditional loops with constant
3909 if (INTEGER_CST_P (inner_size
))
3912 && !forall_tmp
->mask
3913 && INTEGER_CST_P (forall_tmp
->size
))
3915 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3916 gfc_array_index_type
,
3917 inner_size
, forall_tmp
->size
);
3918 forall_tmp
= forall_tmp
->prev_nest
;
3921 /* If there are no loops left, we have our constant result. */
3926 /* Otherwise, create a temporary variable to compute the result. */
3927 number
= gfc_create_var (gfc_array_index_type
, "num");
3928 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3930 gfc_start_block (&body
);
3931 if (inner_size_body
)
3932 gfc_add_block_to_block (&body
, inner_size_body
);
3934 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3935 gfc_array_index_type
, number
, inner_size
);
3938 gfc_add_modify (&body
, number
, tmp
);
3939 tmp
= gfc_finish_block (&body
);
3941 /* Generate loops. */
3942 if (forall_tmp
!= NULL
)
3943 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3945 gfc_add_expr_to_block (block
, tmp
);
3951 /* Allocate temporary for forall construct. SIZE is the size of temporary
3952 needed. PTEMP1 is returned for space free. */
3955 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3962 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3963 if (!integer_onep (unit
))
3964 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3965 gfc_array_index_type
, size
, unit
);
3970 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3973 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3978 /* Allocate temporary for forall construct according to the information in
3979 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3980 assignment inside forall. PTEMP1 is returned for space free. */
3983 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3984 tree inner_size
, stmtblock_t
* inner_size_body
,
3985 stmtblock_t
* block
, tree
* ptemp1
)
3989 /* Calculate the total size of temporary needed in forall construct. */
3990 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3991 inner_size_body
, block
);
3993 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3997 /* Handle assignments inside forall which need temporary.
3999 forall (i=start:end:stride; maskexpr)
4002 (where e,f<i> are arbitrary expressions possibly involving i
4003 and there is a dependency between e<i> and f<i>)
4005 masktmp(:) = maskexpr(:)
4010 for (i = start; i <= end; i += stride)
4014 for (i = start; i <= end; i += stride)
4016 if (masktmp[maskindex++])
4017 tmp[count1++] = f<i>
4021 for (i = start; i <= end; i += stride)
4023 if (masktmp[maskindex++])
4024 e<i> = tmp[count1++]
4029 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4030 tree wheremask
, bool invert
,
4031 forall_info
* nested_forall_info
,
4032 stmtblock_t
* block
)
4040 stmtblock_t inner_size_body
;
4042 /* Create vars. count1 is the current iterator number of the nested
4044 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4046 /* Count is the wheremask index. */
4049 count
= gfc_create_var (gfc_array_index_type
, "count");
4050 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4055 /* Initialize count1. */
4056 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4058 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4059 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4060 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4061 if (expr1
->ts
.type
== BT_CHARACTER
)
4064 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
4067 gfc_init_se (&ssse
, NULL
);
4068 gfc_conv_expr (&ssse
, expr1
);
4069 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4070 ssse
.string_length
);
4074 if (!expr1
->ts
.u
.cl
->backend_decl
)
4077 gcc_assert (expr1
->ts
.u
.cl
->length
);
4078 gfc_init_se (&tse
, NULL
);
4079 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4080 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4082 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4083 expr1
->ts
.u
.cl
->backend_decl
);
4087 type
= gfc_typenode_for_spec (&expr1
->ts
);
4089 gfc_init_block (&inner_size_body
);
4090 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4093 /* Allocate temporary for nested forall construct according to the
4094 information in nested_forall_info and inner_size. */
4095 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4096 &inner_size_body
, block
, &ptemp1
);
4098 /* Generate codes to copy rhs to the temporary . */
4099 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4102 /* Generate body and loops according to the information in
4103 nested_forall_info. */
4104 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4105 gfc_add_expr_to_block (block
, tmp
);
4108 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4112 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4114 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4115 rss; there must be a better way. */
4116 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4119 /* Generate codes to copy the temporary to lhs. */
4120 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4124 /* Generate body and loops according to the information in
4125 nested_forall_info. */
4126 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4127 gfc_add_expr_to_block (block
, tmp
);
4131 /* Free the temporary. */
4132 tmp
= gfc_call_free (ptemp1
);
4133 gfc_add_expr_to_block (block
, tmp
);
4138 /* Translate pointer assignment inside FORALL which need temporary. */
4141 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4142 forall_info
* nested_forall_info
,
4143 stmtblock_t
* block
)
4150 gfc_array_info
*info
;
4157 tree tmp
, tmp1
, ptemp1
;
4159 count
= gfc_create_var (gfc_array_index_type
, "count");
4160 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4162 inner_size
= gfc_index_one_node
;
4163 lss
= gfc_walk_expr (expr1
);
4164 rss
= gfc_walk_expr (expr2
);
4165 if (lss
== gfc_ss_terminator
)
4167 type
= gfc_typenode_for_spec (&expr1
->ts
);
4168 type
= build_pointer_type (type
);
4170 /* Allocate temporary for nested forall construct according to the
4171 information in nested_forall_info and inner_size. */
4172 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4173 inner_size
, NULL
, block
, &ptemp1
);
4174 gfc_start_block (&body
);
4175 gfc_init_se (&lse
, NULL
);
4176 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4177 gfc_init_se (&rse
, NULL
);
4178 rse
.want_pointer
= 1;
4179 gfc_conv_expr (&rse
, expr2
);
4180 gfc_add_block_to_block (&body
, &rse
.pre
);
4181 gfc_add_modify (&body
, lse
.expr
,
4182 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4183 gfc_add_block_to_block (&body
, &rse
.post
);
4185 /* Increment count. */
4186 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4187 count
, gfc_index_one_node
);
4188 gfc_add_modify (&body
, count
, tmp
);
4190 tmp
= gfc_finish_block (&body
);
4192 /* Generate body and loops according to the information in
4193 nested_forall_info. */
4194 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4195 gfc_add_expr_to_block (block
, tmp
);
4198 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4200 gfc_start_block (&body
);
4201 gfc_init_se (&lse
, NULL
);
4202 gfc_init_se (&rse
, NULL
);
4203 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4204 lse
.want_pointer
= 1;
4205 gfc_conv_expr (&lse
, expr1
);
4206 gfc_add_block_to_block (&body
, &lse
.pre
);
4207 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4208 gfc_add_block_to_block (&body
, &lse
.post
);
4209 /* Increment count. */
4210 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4211 count
, gfc_index_one_node
);
4212 gfc_add_modify (&body
, count
, tmp
);
4213 tmp
= gfc_finish_block (&body
);
4215 /* Generate body and loops according to the information in
4216 nested_forall_info. */
4217 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4218 gfc_add_expr_to_block (block
, tmp
);
4222 gfc_init_loopinfo (&loop
);
4224 /* Associate the SS with the loop. */
4225 gfc_add_ss_to_loop (&loop
, rss
);
4227 /* Setup the scalarizing loops and bounds. */
4228 gfc_conv_ss_startstride (&loop
);
4230 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4232 info
= &rss
->info
->data
.array
;
4233 desc
= info
->descriptor
;
4235 /* Make a new descriptor. */
4236 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4237 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4238 loop
.from
, loop
.to
, 1,
4239 GFC_ARRAY_UNKNOWN
, true);
4241 /* Allocate temporary for nested forall construct. */
4242 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4243 inner_size
, NULL
, block
, &ptemp1
);
4244 gfc_start_block (&body
);
4245 gfc_init_se (&lse
, NULL
);
4246 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4247 lse
.direct_byref
= 1;
4248 gfc_conv_expr_descriptor (&lse
, expr2
);
4250 gfc_add_block_to_block (&body
, &lse
.pre
);
4251 gfc_add_block_to_block (&body
, &lse
.post
);
4253 /* Increment count. */
4254 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4255 count
, gfc_index_one_node
);
4256 gfc_add_modify (&body
, count
, tmp
);
4258 tmp
= gfc_finish_block (&body
);
4260 /* Generate body and loops according to the information in
4261 nested_forall_info. */
4262 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4263 gfc_add_expr_to_block (block
, tmp
);
4266 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4268 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4269 gfc_init_se (&lse
, NULL
);
4270 gfc_conv_expr_descriptor (&lse
, expr1
);
4271 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4272 gfc_start_block (&body
);
4273 gfc_add_block_to_block (&body
, &lse
.pre
);
4274 gfc_add_block_to_block (&body
, &lse
.post
);
4276 /* Increment count. */
4277 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4278 count
, gfc_index_one_node
);
4279 gfc_add_modify (&body
, count
, tmp
);
4281 tmp
= gfc_finish_block (&body
);
4283 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4284 gfc_add_expr_to_block (block
, tmp
);
4286 /* Free the temporary. */
4289 tmp
= gfc_call_free (ptemp1
);
4290 gfc_add_expr_to_block (block
, tmp
);
4295 /* FORALL and WHERE statements are really nasty, especially when you nest
4296 them. All the rhs of a forall assignment must be evaluated before the
4297 actual assignments are performed. Presumably this also applies to all the
4298 assignments in an inner where statement. */
4300 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4301 linear array, relying on the fact that we process in the same order in all
4304 forall (i=start:end:stride; maskexpr)
4308 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4310 count = ((end + 1 - start) / stride)
4311 masktmp(:) = maskexpr(:)
4314 for (i = start; i <= end; i += stride)
4316 if (masktmp[maskindex++])
4320 for (i = start; i <= end; i += stride)
4322 if (masktmp[maskindex++])
4326 Note that this code only works when there are no dependencies.
4327 Forall loop with array assignments and data dependencies are a real pain,
4328 because the size of the temporary cannot always be determined before the
4329 loop is executed. This problem is compounded by the presence of nested
4334 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4351 tree cycle_label
= NULL_TREE
;
4355 gfc_forall_iterator
*fa
;
4358 gfc_saved_var
*saved_vars
;
4359 iter_info
*this_forall
;
4363 /* Do nothing if the mask is false. */
4365 && code
->expr1
->expr_type
== EXPR_CONSTANT
4366 && !code
->expr1
->value
.logical
)
4367 return build_empty_stmt (input_location
);
4370 /* Count the FORALL index number. */
4371 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4375 /* Allocate the space for var, start, end, step, varexpr. */
4376 var
= XCNEWVEC (tree
, nvar
);
4377 start
= XCNEWVEC (tree
, nvar
);
4378 end
= XCNEWVEC (tree
, nvar
);
4379 step
= XCNEWVEC (tree
, nvar
);
4380 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4381 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4383 /* Allocate the space for info. */
4384 info
= XCNEW (forall_info
);
4386 gfc_start_block (&pre
);
4387 gfc_init_block (&post
);
4388 gfc_init_block (&block
);
4391 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4393 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4395 /* Allocate space for this_forall. */
4396 this_forall
= XCNEW (iter_info
);
4398 /* Create a temporary variable for the FORALL index. */
4399 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4400 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4401 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4403 /* Record it in this_forall. */
4404 this_forall
->var
= var
[n
];
4406 /* Replace the index symbol's backend_decl with the temporary decl. */
4407 sym
->backend_decl
= var
[n
];
4409 /* Work out the start, end and stride for the loop. */
4410 gfc_init_se (&se
, NULL
);
4411 gfc_conv_expr_val (&se
, fa
->start
);
4412 /* Record it in this_forall. */
4413 this_forall
->start
= se
.expr
;
4414 gfc_add_block_to_block (&block
, &se
.pre
);
4417 gfc_init_se (&se
, NULL
);
4418 gfc_conv_expr_val (&se
, fa
->end
);
4419 /* Record it in this_forall. */
4420 this_forall
->end
= se
.expr
;
4421 gfc_make_safe_expr (&se
);
4422 gfc_add_block_to_block (&block
, &se
.pre
);
4425 gfc_init_se (&se
, NULL
);
4426 gfc_conv_expr_val (&se
, fa
->stride
);
4427 /* Record it in this_forall. */
4428 this_forall
->step
= se
.expr
;
4429 gfc_make_safe_expr (&se
);
4430 gfc_add_block_to_block (&block
, &se
.pre
);
4433 /* Set the NEXT field of this_forall to NULL. */
4434 this_forall
->next
= NULL
;
4435 /* Link this_forall to the info construct. */
4436 if (info
->this_loop
)
4438 iter_info
*iter_tmp
= info
->this_loop
;
4439 while (iter_tmp
->next
!= NULL
)
4440 iter_tmp
= iter_tmp
->next
;
4441 iter_tmp
->next
= this_forall
;
4444 info
->this_loop
= this_forall
;
4450 /* Calculate the size needed for the current forall level. */
4451 size
= gfc_index_one_node
;
4452 for (n
= 0; n
< nvar
; n
++)
4454 /* size = (end + step - start) / step. */
4455 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4457 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4459 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4461 tmp
= convert (gfc_array_index_type
, tmp
);
4463 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4467 /* Record the nvar and size of current forall level. */
4473 /* If the mask is .true., consider the FORALL unconditional. */
4474 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4475 && code
->expr1
->value
.logical
)
4483 /* First we need to allocate the mask. */
4486 /* As the mask array can be very big, prefer compact boolean types. */
4487 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4488 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4489 size
, NULL
, &block
, &pmask
);
4490 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4492 /* Record them in the info structure. */
4493 info
->maskindex
= maskindex
;
4498 /* No mask was specified. */
4499 maskindex
= NULL_TREE
;
4500 mask
= pmask
= NULL_TREE
;
4503 /* Link the current forall level to nested_forall_info. */
4504 info
->prev_nest
= nested_forall_info
;
4505 nested_forall_info
= info
;
4507 /* Copy the mask into a temporary variable if required.
4508 For now we assume a mask temporary is needed. */
4511 /* As the mask array can be very big, prefer compact boolean types. */
4512 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4514 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4516 /* Start of mask assignment loop body. */
4517 gfc_start_block (&body
);
4519 /* Evaluate the mask expression. */
4520 gfc_init_se (&se
, NULL
);
4521 gfc_conv_expr_val (&se
, code
->expr1
);
4522 gfc_add_block_to_block (&body
, &se
.pre
);
4524 /* Store the mask. */
4525 se
.expr
= convert (mask_type
, se
.expr
);
4527 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4528 gfc_add_modify (&body
, tmp
, se
.expr
);
4530 /* Advance to the next mask element. */
4531 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4532 maskindex
, gfc_index_one_node
);
4533 gfc_add_modify (&body
, maskindex
, tmp
);
4535 /* Generate the loops. */
4536 tmp
= gfc_finish_block (&body
);
4537 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4538 gfc_add_expr_to_block (&block
, tmp
);
4541 if (code
->op
== EXEC_DO_CONCURRENT
)
4543 gfc_init_block (&body
);
4544 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4545 code
->cycle_label
= cycle_label
;
4546 tmp
= gfc_trans_code (code
->block
->next
);
4547 gfc_add_expr_to_block (&body
, tmp
);
4549 if (TREE_USED (cycle_label
))
4551 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4552 gfc_add_expr_to_block (&body
, tmp
);
4555 tmp
= gfc_finish_block (&body
);
4556 nested_forall_info
->do_concurrent
= true;
4557 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4558 gfc_add_expr_to_block (&block
, tmp
);
4562 c
= code
->block
->next
;
4564 /* TODO: loop merging in FORALL statements. */
4565 /* Now that we've got a copy of the mask, generate the assignment loops. */
4571 /* A scalar or array assignment. DO the simple check for
4572 lhs to rhs dependencies. These make a temporary for the
4573 rhs and form a second forall block to copy to variable. */
4574 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4576 /* Temporaries due to array assignment data dependencies introduce
4577 no end of problems. */
4578 if (need_temp
|| flag_test_forall_temp
)
4579 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4580 nested_forall_info
, &block
);
4583 /* Use the normal assignment copying routines. */
4584 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4586 /* Generate body and loops. */
4587 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4589 gfc_add_expr_to_block (&block
, tmp
);
4592 /* Cleanup any temporary symtrees that have been made to deal
4593 with dependencies. */
4595 cleanup_forall_symtrees (c
);
4600 /* Translate WHERE or WHERE construct nested in FORALL. */
4601 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4604 /* Pointer assignment inside FORALL. */
4605 case EXEC_POINTER_ASSIGN
:
4606 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4607 /* Avoid cases where a temporary would never be needed and where
4608 the temp code is guaranteed to fail. */
4610 || (flag_test_forall_temp
4611 && c
->expr2
->expr_type
!= EXPR_CONSTANT
4612 && c
->expr2
->expr_type
!= EXPR_NULL
))
4613 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4614 nested_forall_info
, &block
);
4617 /* Use the normal assignment copying routines. */
4618 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4620 /* Generate body and loops. */
4621 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4623 gfc_add_expr_to_block (&block
, tmp
);
4628 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4629 gfc_add_expr_to_block (&block
, tmp
);
4632 /* Explicit subroutine calls are prevented by the frontend but interface
4633 assignments can legitimately produce them. */
4634 case EXEC_ASSIGN_CALL
:
4635 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4636 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4637 gfc_add_expr_to_block (&block
, tmp
);
4648 /* Restore the original index variables. */
4649 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4650 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4652 /* Free the space for var, start, end, step, varexpr. */
4660 for (this_forall
= info
->this_loop
; this_forall
;)
4662 iter_info
*next
= this_forall
->next
;
4667 /* Free the space for this forall_info. */
4672 /* Free the temporary for the mask. */
4673 tmp
= gfc_call_free (pmask
);
4674 gfc_add_expr_to_block (&block
, tmp
);
4677 pushdecl (maskindex
);
4679 gfc_add_block_to_block (&pre
, &block
);
4680 gfc_add_block_to_block (&pre
, &post
);
4682 return gfc_finish_block (&pre
);
4686 /* Translate the FORALL statement or construct. */
4688 tree
gfc_trans_forall (gfc_code
* code
)
4690 return gfc_trans_forall_1 (code
, NULL
);
4694 /* Translate the DO CONCURRENT construct. */
4696 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4698 return gfc_trans_forall_1 (code
, NULL
);
4702 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4703 If the WHERE construct is nested in FORALL, compute the overall temporary
4704 needed by the WHERE mask expression multiplied by the iterator number of
4706 ME is the WHERE mask expression.
4707 MASK is the current execution mask upon input, whose sense may or may
4708 not be inverted as specified by the INVERT argument.
4709 CMASK is the updated execution mask on output, or NULL if not required.
4710 PMASK is the pending execution mask on output, or NULL if not required.
4711 BLOCK is the block in which to place the condition evaluation loops. */
4714 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4715 tree mask
, bool invert
, tree cmask
, tree pmask
,
4716 tree mask_type
, stmtblock_t
* block
)
4721 stmtblock_t body
, body1
;
4722 tree count
, cond
, mtmp
;
4725 gfc_init_loopinfo (&loop
);
4727 lss
= gfc_walk_expr (me
);
4728 rss
= gfc_walk_expr (me
);
4730 /* Variable to index the temporary. */
4731 count
= gfc_create_var (gfc_array_index_type
, "count");
4732 /* Initialize count. */
4733 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4735 gfc_start_block (&body
);
4737 gfc_init_se (&rse
, NULL
);
4738 gfc_init_se (&lse
, NULL
);
4740 if (lss
== gfc_ss_terminator
)
4742 gfc_init_block (&body1
);
4746 /* Initialize the loop. */
4747 gfc_init_loopinfo (&loop
);
4749 /* We may need LSS to determine the shape of the expression. */
4750 gfc_add_ss_to_loop (&loop
, lss
);
4751 gfc_add_ss_to_loop (&loop
, rss
);
4753 gfc_conv_ss_startstride (&loop
);
4754 gfc_conv_loop_setup (&loop
, &me
->where
);
4756 gfc_mark_ss_chain_used (rss
, 1);
4757 /* Start the loop body. */
4758 gfc_start_scalarized_body (&loop
, &body1
);
4760 /* Translate the expression. */
4761 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4763 gfc_conv_expr (&rse
, me
);
4766 /* Variable to evaluate mask condition. */
4767 cond
= gfc_create_var (mask_type
, "cond");
4768 if (mask
&& (cmask
|| pmask
))
4769 mtmp
= gfc_create_var (mask_type
, "mask");
4770 else mtmp
= NULL_TREE
;
4772 gfc_add_block_to_block (&body1
, &lse
.pre
);
4773 gfc_add_block_to_block (&body1
, &rse
.pre
);
4775 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4777 if (mask
&& (cmask
|| pmask
))
4779 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4781 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4782 gfc_add_modify (&body1
, mtmp
, tmp
);
4787 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4790 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4792 gfc_add_modify (&body1
, tmp1
, tmp
);
4797 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4798 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4800 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4802 gfc_add_modify (&body1
, tmp1
, tmp
);
4805 gfc_add_block_to_block (&body1
, &lse
.post
);
4806 gfc_add_block_to_block (&body1
, &rse
.post
);
4808 if (lss
== gfc_ss_terminator
)
4810 gfc_add_block_to_block (&body
, &body1
);
4814 /* Increment count. */
4815 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4816 count
, gfc_index_one_node
);
4817 gfc_add_modify (&body1
, count
, tmp1
);
4819 /* Generate the copying loops. */
4820 gfc_trans_scalarizing_loops (&loop
, &body1
);
4822 gfc_add_block_to_block (&body
, &loop
.pre
);
4823 gfc_add_block_to_block (&body
, &loop
.post
);
4825 gfc_cleanup_loop (&loop
);
4826 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4827 as tree nodes in SS may not be valid in different scope. */
4830 tmp1
= gfc_finish_block (&body
);
4831 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4832 if (nested_forall_info
!= NULL
)
4833 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4835 gfc_add_expr_to_block (block
, tmp1
);
4839 /* Translate an assignment statement in a WHERE statement or construct
4840 statement. The MASK expression is used to control which elements
4841 of EXPR1 shall be assigned. The sense of MASK is specified by
4845 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4846 tree mask
, bool invert
,
4847 tree count1
, tree count2
,
4853 gfc_ss
*lss_section
;
4860 tree index
, maskexpr
;
4862 /* A defined assignment. */
4863 if (cnext
&& cnext
->resolved_sym
)
4864 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4867 /* TODO: handle this special case.
4868 Special case a single function returning an array. */
4869 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4871 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4877 /* Assignment of the form lhs = rhs. */
4878 gfc_start_block (&block
);
4880 gfc_init_se (&lse
, NULL
);
4881 gfc_init_se (&rse
, NULL
);
4884 lss
= gfc_walk_expr (expr1
);
4887 /* In each where-assign-stmt, the mask-expr and the variable being
4888 defined shall be arrays of the same shape. */
4889 gcc_assert (lss
!= gfc_ss_terminator
);
4891 /* The assignment needs scalarization. */
4894 /* Find a non-scalar SS from the lhs. */
4895 while (lss_section
!= gfc_ss_terminator
4896 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4897 lss_section
= lss_section
->next
;
4899 gcc_assert (lss_section
!= gfc_ss_terminator
);
4901 /* Initialize the scalarizer. */
4902 gfc_init_loopinfo (&loop
);
4905 rss
= gfc_walk_expr (expr2
);
4906 if (rss
== gfc_ss_terminator
)
4908 /* The rhs is scalar. Add a ss for the expression. */
4909 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4910 rss
->info
->where
= 1;
4913 /* Associate the SS with the loop. */
4914 gfc_add_ss_to_loop (&loop
, lss
);
4915 gfc_add_ss_to_loop (&loop
, rss
);
4917 /* Calculate the bounds of the scalarization. */
4918 gfc_conv_ss_startstride (&loop
);
4920 /* Resolve any data dependencies in the statement. */
4921 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4923 /* Setup the scalarizing loops. */
4924 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4926 /* Setup the gfc_se structures. */
4927 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4928 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4931 gfc_mark_ss_chain_used (rss
, 1);
4932 if (loop
.temp_ss
== NULL
)
4935 gfc_mark_ss_chain_used (lss
, 1);
4939 lse
.ss
= loop
.temp_ss
;
4940 gfc_mark_ss_chain_used (lss
, 3);
4941 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4944 /* Start the scalarized loop body. */
4945 gfc_start_scalarized_body (&loop
, &body
);
4947 /* Translate the expression. */
4948 gfc_conv_expr (&rse
, expr2
);
4949 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4950 gfc_conv_tmp_array_ref (&lse
);
4952 gfc_conv_expr (&lse
, expr1
);
4954 /* Form the mask expression according to the mask. */
4956 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4958 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4959 TREE_TYPE (maskexpr
), maskexpr
);
4961 /* Use the scalar assignment as is. */
4962 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4963 false, loop
.temp_ss
== NULL
);
4965 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4967 gfc_add_expr_to_block (&body
, tmp
);
4969 if (lss
== gfc_ss_terminator
)
4971 /* Increment count1. */
4972 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4973 count1
, gfc_index_one_node
);
4974 gfc_add_modify (&body
, count1
, tmp
);
4976 /* Use the scalar assignment as is. */
4977 gfc_add_block_to_block (&block
, &body
);
4981 gcc_assert (lse
.ss
== gfc_ss_terminator
4982 && rse
.ss
== gfc_ss_terminator
);
4984 if (loop
.temp_ss
!= NULL
)
4986 /* Increment count1 before finish the main body of a scalarized
4988 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4989 gfc_array_index_type
, count1
, gfc_index_one_node
);
4990 gfc_add_modify (&body
, count1
, tmp
);
4991 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4993 /* We need to copy the temporary to the actual lhs. */
4994 gfc_init_se (&lse
, NULL
);
4995 gfc_init_se (&rse
, NULL
);
4996 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4997 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4999 rse
.ss
= loop
.temp_ss
;
5002 gfc_conv_tmp_array_ref (&rse
);
5003 gfc_conv_expr (&lse
, expr1
);
5005 gcc_assert (lse
.ss
== gfc_ss_terminator
5006 && rse
.ss
== gfc_ss_terminator
);
5008 /* Form the mask expression according to the mask tree list. */
5010 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5012 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5013 TREE_TYPE (maskexpr
), maskexpr
);
5015 /* Use the scalar assignment as is. */
5016 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
5017 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
5018 build_empty_stmt (input_location
));
5019 gfc_add_expr_to_block (&body
, tmp
);
5021 /* Increment count2. */
5022 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5023 gfc_array_index_type
, count2
,
5024 gfc_index_one_node
);
5025 gfc_add_modify (&body
, count2
, tmp
);
5029 /* Increment count1. */
5030 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5031 gfc_array_index_type
, count1
,
5032 gfc_index_one_node
);
5033 gfc_add_modify (&body
, count1
, tmp
);
5036 /* Generate the copying loops. */
5037 gfc_trans_scalarizing_loops (&loop
, &body
);
5039 /* Wrap the whole thing up. */
5040 gfc_add_block_to_block (&block
, &loop
.pre
);
5041 gfc_add_block_to_block (&block
, &loop
.post
);
5042 gfc_cleanup_loop (&loop
);
5045 return gfc_finish_block (&block
);
5049 /* Translate the WHERE construct or statement.
5050 This function can be called iteratively to translate the nested WHERE
5051 construct or statement.
5052 MASK is the control mask. */
5055 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
5056 forall_info
* nested_forall_info
, stmtblock_t
* block
)
5058 stmtblock_t inner_size_body
;
5059 tree inner_size
, size
;
5068 tree count1
, count2
;
5072 tree pcmask
= NULL_TREE
;
5073 tree ppmask
= NULL_TREE
;
5074 tree cmask
= NULL_TREE
;
5075 tree pmask
= NULL_TREE
;
5076 gfc_actual_arglist
*arg
;
5078 /* the WHERE statement or the WHERE construct statement. */
5079 cblock
= code
->block
;
5081 /* As the mask array can be very big, prefer compact boolean types. */
5082 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5084 /* Determine which temporary masks are needed. */
5087 /* One clause: No ELSEWHEREs. */
5088 need_cmask
= (cblock
->next
!= 0);
5091 else if (cblock
->block
->block
)
5093 /* Three or more clauses: Conditional ELSEWHEREs. */
5097 else if (cblock
->next
)
5099 /* Two clauses, the first non-empty. */
5101 need_pmask
= (mask
!= NULL_TREE
5102 && cblock
->block
->next
!= 0);
5104 else if (!cblock
->block
->next
)
5106 /* Two clauses, both empty. */
5110 /* Two clauses, the first empty, the second non-empty. */
5113 need_cmask
= (cblock
->block
->expr1
!= 0);
5122 if (need_cmask
|| need_pmask
)
5124 /* Calculate the size of temporary needed by the mask-expr. */
5125 gfc_init_block (&inner_size_body
);
5126 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5127 &inner_size_body
, &lss
, &rss
);
5129 gfc_free_ss_chain (lss
);
5130 gfc_free_ss_chain (rss
);
5132 /* Calculate the total size of temporary needed. */
5133 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5134 &inner_size_body
, block
);
5136 /* Check whether the size is negative. */
5137 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, size
,
5138 gfc_index_zero_node
);
5139 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5140 cond
, gfc_index_zero_node
, size
);
5141 size
= gfc_evaluate_now (size
, block
);
5143 /* Allocate temporary for WHERE mask if needed. */
5145 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5148 /* Allocate temporary for !mask if needed. */
5150 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5156 /* Each time around this loop, the where clause is conditional
5157 on the value of mask and invert, which are updated at the
5158 bottom of the loop. */
5160 /* Has mask-expr. */
5163 /* Ensure that the WHERE mask will be evaluated exactly once.
5164 If there are no statements in this WHERE/ELSEWHERE clause,
5165 then we don't need to update the control mask (cmask).
5166 If this is the last clause of the WHERE construct, then
5167 we don't need to update the pending control mask (pmask). */
5169 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5171 cblock
->next
? cmask
: NULL_TREE
,
5172 cblock
->block
? pmask
: NULL_TREE
,
5175 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5177 (cblock
->next
|| cblock
->block
)
5178 ? cmask
: NULL_TREE
,
5179 NULL_TREE
, mask_type
, block
);
5183 /* It's a final elsewhere-stmt. No mask-expr is present. */
5187 /* The body of this where clause are controlled by cmask with
5188 sense specified by invert. */
5190 /* Get the assignment statement of a WHERE statement, or the first
5191 statement in where-body-construct of a WHERE construct. */
5192 cnext
= cblock
->next
;
5197 /* WHERE assignment statement. */
5198 case EXEC_ASSIGN_CALL
:
5200 arg
= cnext
->ext
.actual
;
5201 expr1
= expr2
= NULL
;
5202 for (; arg
; arg
= arg
->next
)
5214 expr1
= cnext
->expr1
;
5215 expr2
= cnext
->expr2
;
5217 if (nested_forall_info
!= NULL
)
5219 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5220 if ((need_temp
|| flag_test_forall_temp
)
5221 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5222 gfc_trans_assign_need_temp (expr1
, expr2
,
5224 nested_forall_info
, block
);
5227 /* Variables to control maskexpr. */
5228 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5229 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5230 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5231 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5233 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5238 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5240 gfc_add_expr_to_block (block
, tmp
);
5245 /* Variables to control maskexpr. */
5246 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5247 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5248 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5249 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5251 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5255 gfc_add_expr_to_block (block
, tmp
);
5260 /* WHERE or WHERE construct is part of a where-body-construct. */
5262 gfc_trans_where_2 (cnext
, cmask
, invert
,
5263 nested_forall_info
, block
);
5270 /* The next statement within the same where-body-construct. */
5271 cnext
= cnext
->next
;
5273 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5274 cblock
= cblock
->block
;
5275 if (mask
== NULL_TREE
)
5277 /* If we're the initial WHERE, we can simply invert the sense
5278 of the current mask to obtain the "mask" for the remaining
5285 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5291 /* If we allocated a pending mask array, deallocate it now. */
5294 tmp
= gfc_call_free (ppmask
);
5295 gfc_add_expr_to_block (block
, tmp
);
5298 /* If we allocated a current mask array, deallocate it now. */
5301 tmp
= gfc_call_free (pcmask
);
5302 gfc_add_expr_to_block (block
, tmp
);
5306 /* Translate a simple WHERE construct or statement without dependencies.
5307 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5308 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5309 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5312 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5314 stmtblock_t block
, body
;
5315 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5316 tree tmp
, cexpr
, tstmt
, estmt
;
5317 gfc_ss
*css
, *tdss
, *tsss
;
5318 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5322 bool maybe_workshare
= false;
5324 /* Allow the scalarizer to workshare simple where loops. */
5325 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5326 == OMPWS_WORKSHARE_FLAG
)
5328 maybe_workshare
= true;
5329 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5332 cond
= cblock
->expr1
;
5333 tdst
= cblock
->next
->expr1
;
5334 tsrc
= cblock
->next
->expr2
;
5335 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5336 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5338 gfc_start_block (&block
);
5339 gfc_init_loopinfo (&loop
);
5341 /* Handle the condition. */
5342 gfc_init_se (&cse
, NULL
);
5343 css
= gfc_walk_expr (cond
);
5344 gfc_add_ss_to_loop (&loop
, css
);
5346 /* Handle the then-clause. */
5347 gfc_init_se (&tdse
, NULL
);
5348 gfc_init_se (&tsse
, NULL
);
5349 tdss
= gfc_walk_expr (tdst
);
5350 tsss
= gfc_walk_expr (tsrc
);
5351 if (tsss
== gfc_ss_terminator
)
5353 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5354 tsss
->info
->where
= 1;
5356 gfc_add_ss_to_loop (&loop
, tdss
);
5357 gfc_add_ss_to_loop (&loop
, tsss
);
5361 /* Handle the else clause. */
5362 gfc_init_se (&edse
, NULL
);
5363 gfc_init_se (&esse
, NULL
);
5364 edss
= gfc_walk_expr (edst
);
5365 esss
= gfc_walk_expr (esrc
);
5366 if (esss
== gfc_ss_terminator
)
5368 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5369 esss
->info
->where
= 1;
5371 gfc_add_ss_to_loop (&loop
, edss
);
5372 gfc_add_ss_to_loop (&loop
, esss
);
5375 gfc_conv_ss_startstride (&loop
);
5376 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5378 gfc_mark_ss_chain_used (css
, 1);
5379 gfc_mark_ss_chain_used (tdss
, 1);
5380 gfc_mark_ss_chain_used (tsss
, 1);
5383 gfc_mark_ss_chain_used (edss
, 1);
5384 gfc_mark_ss_chain_used (esss
, 1);
5387 gfc_start_scalarized_body (&loop
, &body
);
5389 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5390 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5391 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5397 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5398 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5403 gfc_conv_expr (&cse
, cond
);
5404 gfc_add_block_to_block (&body
, &cse
.pre
);
5407 gfc_conv_expr (&tsse
, tsrc
);
5408 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5409 gfc_conv_tmp_array_ref (&tdse
);
5411 gfc_conv_expr (&tdse
, tdst
);
5415 gfc_conv_expr (&esse
, esrc
);
5416 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5417 gfc_conv_tmp_array_ref (&edse
);
5419 gfc_conv_expr (&edse
, edst
);
5422 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5423 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5425 : build_empty_stmt (input_location
);
5426 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5427 gfc_add_expr_to_block (&body
, tmp
);
5428 gfc_add_block_to_block (&body
, &cse
.post
);
5430 if (maybe_workshare
)
5431 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5432 gfc_trans_scalarizing_loops (&loop
, &body
);
5433 gfc_add_block_to_block (&block
, &loop
.pre
);
5434 gfc_add_block_to_block (&block
, &loop
.post
);
5435 gfc_cleanup_loop (&loop
);
5437 return gfc_finish_block (&block
);
5440 /* As the WHERE or WHERE construct statement can be nested, we call
5441 gfc_trans_where_2 to do the translation, and pass the initial
5442 NULL values for both the control mask and the pending control mask. */
5445 gfc_trans_where (gfc_code
* code
)
5451 cblock
= code
->block
;
5453 && cblock
->next
->op
== EXEC_ASSIGN
5454 && !cblock
->next
->next
)
5456 eblock
= cblock
->block
;
5459 /* A simple "WHERE (cond) x = y" statement or block is
5460 dependence free if cond is not dependent upon writing x,
5461 and the source y is unaffected by the destination x. */
5462 if (!gfc_check_dependency (cblock
->next
->expr1
,
5464 && !gfc_check_dependency (cblock
->next
->expr1
,
5465 cblock
->next
->expr2
, 0))
5466 return gfc_trans_where_3 (cblock
, NULL
);
5468 else if (!eblock
->expr1
5471 && eblock
->next
->op
== EXEC_ASSIGN
5472 && !eblock
->next
->next
)
5474 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5475 block is dependence free if cond is not dependent on writes
5476 to x1 and x2, y1 is not dependent on writes to x2, and y2
5477 is not dependent on writes to x1, and both y's are not
5478 dependent upon their own x's. In addition to this, the
5479 final two dependency checks below exclude all but the same
5480 array reference if the where and elswhere destinations
5481 are the same. In short, this is VERY conservative and this
5482 is needed because the two loops, required by the standard
5483 are coalesced in gfc_trans_where_3. */
5484 if (!gfc_check_dependency (cblock
->next
->expr1
,
5486 && !gfc_check_dependency (eblock
->next
->expr1
,
5488 && !gfc_check_dependency (cblock
->next
->expr1
,
5489 eblock
->next
->expr2
, 1)
5490 && !gfc_check_dependency (eblock
->next
->expr1
,
5491 cblock
->next
->expr2
, 1)
5492 && !gfc_check_dependency (cblock
->next
->expr1
,
5493 cblock
->next
->expr2
, 1)
5494 && !gfc_check_dependency (eblock
->next
->expr1
,
5495 eblock
->next
->expr2
, 1)
5496 && !gfc_check_dependency (cblock
->next
->expr1
,
5497 eblock
->next
->expr1
, 0)
5498 && !gfc_check_dependency (eblock
->next
->expr1
,
5499 cblock
->next
->expr1
, 0))
5500 return gfc_trans_where_3 (cblock
, eblock
);
5504 gfc_start_block (&block
);
5506 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5508 return gfc_finish_block (&block
);
5512 /* CYCLE a DO loop. The label decl has already been created by
5513 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5514 node at the head of the loop. We must mark the label as used. */
5517 gfc_trans_cycle (gfc_code
* code
)
5521 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5522 gcc_assert (cycle_label
);
5524 TREE_USED (cycle_label
) = 1;
5525 return build1_v (GOTO_EXPR
, cycle_label
);
5529 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5530 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5534 gfc_trans_exit (gfc_code
* code
)
5538 exit_label
= code
->ext
.which_construct
->exit_label
;
5539 gcc_assert (exit_label
);
5541 TREE_USED (exit_label
) = 1;
5542 return build1_v (GOTO_EXPR
, exit_label
);
5546 /* Get the initializer expression for the code and expr of an allocate.
5547 When no initializer is needed return NULL. */
5550 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
5552 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
5555 /* An explicit type was given in allocate ( T:: object). */
5556 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
5557 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
5558 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
5559 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
5561 if (gfc_bt_struct (expr
->ts
.type
)
5562 && (expr
->ts
.u
.derived
->attr
.alloc_comp
5563 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
5564 return gfc_default_initializer (&expr
->ts
);
5566 if (expr
->ts
.type
== BT_CLASS
5567 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
5568 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
5569 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
5574 /* Translate the ALLOCATE statement. */
5577 gfc_trans_allocate (gfc_code
* code
)
5580 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
5590 tree al_vptr
, al_len
;
5591 /* If an expr3 is present, then store the tree for accessing its
5592 _vptr, and _len components in the variables, respectively. The
5593 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5594 the trees may be the NULL_TREE indicating that this is not
5595 available for expr3's type. */
5596 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5597 /* Classify what expr3 stores. */
5598 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5602 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
5603 bool needs_caf_sync
, caf_refs_comp
;
5604 gfc_symtree
*newsym
= NULL
;
5605 symbol_attribute caf_attr
;
5606 gfc_actual_arglist
*param_list
;
5608 if (!code
->ext
.alloc
.list
)
5611 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5612 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5613 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5615 is_coarray
= needs_caf_sync
= false;
5617 gfc_init_block (&block
);
5618 gfc_init_block (&post
);
5620 /* STAT= (and maybe ERRMSG=) is present. */
5624 tree gfc_int4_type_node
= gfc_get_int_type (4);
5625 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5627 /* ERRMSG= only makes sense with STAT=. */
5630 gfc_init_se (&se
, NULL
);
5631 se
.want_pointer
= 1;
5632 gfc_conv_expr_lhs (&se
, code
->expr2
);
5634 errlen
= se
.string_length
;
5638 errmsg
= null_pointer_node
;
5639 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5642 /* GOTO destinations. */
5643 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5644 label_finish
= gfc_build_label_decl (NULL_TREE
);
5645 TREE_USED (label_finish
) = 0;
5648 /* When an expr3 is present evaluate it only once. The standards prevent a
5649 dependency of expr3 on the objects in the allocate list. An expr3 can
5650 be pre-evaluated in all cases. One just has to make sure, to use the
5651 correct way, i.e., to get the descriptor or to get a reference
5655 bool vtab_needed
= false, temp_var_needed
= false,
5656 temp_obj_created
= false;
5658 is_coarray
= gfc_is_coarray (code
->expr3
);
5660 /* Figure whether we need the vtab from expr3. */
5661 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5663 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5665 gfc_init_se (&se
, NULL
);
5666 /* When expr3 is a variable, i.e., a very simple expression,
5667 then convert it once here. */
5668 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5669 || code
->expr3
->expr_type
== EXPR_ARRAY
5670 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5672 if (!code
->expr3
->mold
5673 || code
->expr3
->ts
.type
== BT_CHARACTER
5675 || code
->ext
.alloc
.arr_spec_from_expr3
)
5677 /* Convert expr3 to a tree. For all "simple" expression just
5678 get the descriptor or the reference, respectively, depending
5679 on the rank of the expr. */
5680 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5681 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5684 gfc_conv_expr_reference (&se
, code
->expr3
);
5686 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5687 NOP_EXPR, which prevents gfortran from getting the vptr
5688 from the source=-expression. Remove the NOP_EXPR and go
5689 with the POINTER_PLUS_EXPR in this case. */
5690 if (code
->expr3
->ts
.type
== BT_CLASS
5691 && TREE_CODE (se
.expr
) == NOP_EXPR
5692 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5693 == POINTER_PLUS_EXPR
5695 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5697 /* Create a temp variable only for component refs to prevent
5698 having to go through the full deref-chain each time and to
5699 simplfy computation of array properties. */
5700 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5705 /* In all other cases evaluate the expr3. */
5706 symbol_attribute attr
;
5707 /* Get the descriptor for all arrays, that are not allocatable or
5708 pointer, because the latter are descriptors already.
5709 The exception are function calls returning a class object:
5710 The descriptor is stored in their results _data component, which
5711 is easier to access, when first a temporary variable for the
5712 result is created and the descriptor retrieved from there. */
5713 attr
= gfc_expr_attr (code
->expr3
);
5714 if (code
->expr3
->rank
!= 0
5715 && ((!attr
.allocatable
&& !attr
.pointer
)
5716 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5717 && (code
->expr3
->ts
.type
!= BT_CLASS
5718 || (code
->expr3
->value
.function
.isym
5719 && code
->expr3
->value
.function
.isym
5720 ->transformational
)))))
5721 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5723 gfc_conv_expr_reference (&se
, code
->expr3
);
5724 if (code
->expr3
->ts
.type
== BT_CLASS
)
5725 gfc_conv_class_to_class (&se
, code
->expr3
,
5729 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
5731 gfc_add_block_to_block (&block
, &se
.pre
);
5732 gfc_add_block_to_block (&post
, &se
.post
);
5734 /* Special case when string in expr3 is zero. */
5735 if (code
->expr3
->ts
.type
== BT_CHARACTER
5736 && integer_zerop (se
.string_length
))
5738 gfc_init_se (&se
, NULL
);
5739 temp_var_needed
= false;
5740 expr3_len
= integer_zero_node
;
5743 /* Prevent aliasing, i.e., se.expr may be already a
5744 variable declaration. */
5745 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5748 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5750 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5752 /* Get the array descriptor and prepare it to be assigned to the
5753 temporary variable var. For classes the array descriptor is
5754 in the _data component and the object goes into the
5755 GFC_DECL_SAVED_DESCRIPTOR. */
5756 if (code
->expr3
->ts
.type
== BT_CLASS
5757 && code
->expr3
->rank
!= 0)
5759 /* When an array_ref was in expr3, then the descriptor is the
5761 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5763 desc
= TREE_OPERAND (tmp
, 0);
5768 tmp
= gfc_class_data_get (tmp
);
5770 if (code
->ext
.alloc
.arr_spec_from_expr3
)
5774 desc
= !is_coarray
? se
.expr
5775 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5776 /* We need a regular (non-UID) symbol here, therefore give a
5778 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5779 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5781 gfc_allocate_lang_decl (var
);
5782 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5784 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5787 if (se
.string_length
)
5788 /* Evaluate it assuming that it also is complicated like expr3. */
5789 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5794 expr3_len
= se
.string_length
;
5797 /* Deallocate any allocatable components in expressions that use a
5798 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
5799 E.g. temporaries of a function call need freeing of their components
5801 if ((code
->expr3
->ts
.type
== BT_DERIVED
5802 || code
->expr3
->ts
.type
== BT_CLASS
)
5803 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
5804 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
)
5806 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
5807 expr3
, code
->expr3
->rank
);
5808 gfc_prepend_expr_to_block (&post
, tmp
);
5811 /* Store what the expr3 is to be used for. */
5812 if (e3_is
== E3_UNSET
)
5813 e3_is
= expr3
!= NULL_TREE
?
5814 (code
->ext
.alloc
.arr_spec_from_expr3
?
5816 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
5819 /* Figure how to get the _vtab entry. This also obtains the tree
5820 expression for accessing the _len component, because only
5821 unlimited polymorphic objects, which are a subcategory of class
5822 types, have a _len component. */
5823 if (code
->expr3
->ts
.type
== BT_CLASS
)
5826 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
5827 build_fold_indirect_ref (expr3
): expr3
;
5828 /* Polymorphic SOURCE: VPTR must be determined at run time.
5829 expr3 may be a temporary array declaration, therefore check for
5830 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5831 if (tmp
!= NULL_TREE
5832 && (e3_is
== E3_DESC
5833 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
5834 && (VAR_P (tmp
) || !code
->expr3
->ref
))
5835 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
5836 tmp
= gfc_class_vptr_get (expr3
);
5839 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5840 gfc_add_vptr_component (rhs
);
5841 gfc_init_se (&se
, NULL
);
5842 se
.want_pointer
= 1;
5843 gfc_conv_expr (&se
, rhs
);
5845 gfc_free_expr (rhs
);
5847 /* Set the element size. */
5848 expr3_esize
= gfc_vptr_size_get (tmp
);
5851 /* Initialize the ref to the _len component. */
5852 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5854 /* Same like for retrieving the _vptr. */
5855 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5856 expr3_len
= gfc_class_len_get (expr3
);
5859 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5860 gfc_add_len_component (rhs
);
5861 gfc_init_se (&se
, NULL
);
5862 gfc_conv_expr (&se
, rhs
);
5863 expr3_len
= se
.expr
;
5864 gfc_free_expr (rhs
);
5870 /* When the object to allocate is polymorphic type, then it
5871 needs its vtab set correctly, so deduce the required _vtab
5872 and _len from the source expression. */
5875 /* VPTR is fixed at compile time. */
5878 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5880 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5881 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5884 /* _len component needs to be set, when ts is a character
5886 if (expr3_len
== NULL_TREE
5887 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5889 if (code
->expr3
->ts
.u
.cl
5890 && code
->expr3
->ts
.u
.cl
->length
)
5892 gfc_init_se (&se
, NULL
);
5893 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5894 gfc_add_block_to_block (&block
, &se
.pre
);
5895 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5897 gcc_assert (expr3_len
);
5899 /* For character arrays only the kind's size is needed, because
5900 the array mem_size is _len * (elem_size = kind_size).
5901 For all other get the element size in the normal way. */
5902 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5903 expr3_esize
= TYPE_SIZE_UNIT (
5904 gfc_get_char_type (code
->expr3
->ts
.kind
));
5906 expr3_esize
= TYPE_SIZE_UNIT (
5907 gfc_typenode_for_spec (&code
->expr3
->ts
));
5909 gcc_assert (expr3_esize
);
5910 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5911 if (e3_is
== E3_MOLD
)
5912 /* The expr3 is no longer valid after this point. */
5915 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5917 /* Compute the explicit typespec given only once for all objects
5919 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5920 expr3_esize
= TYPE_SIZE_UNIT (
5921 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5922 else if (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
)
5925 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5926 gfc_init_se (&se_sz
, NULL
);
5927 gfc_conv_expr (&se_sz
, sz
);
5929 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5930 tmp
= TYPE_SIZE_UNIT (tmp
);
5931 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5932 gfc_add_block_to_block (&block
, &se_sz
.pre
);
5933 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5934 TREE_TYPE (se_sz
.expr
),
5936 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
5939 expr3_esize
= NULL_TREE
;
5942 /* The routine gfc_trans_assignment () already implements all
5943 techniques needed. Unfortunately we may have a temporary
5944 variable for the source= expression here. When that is the
5945 case convert this variable into a temporary gfc_expr of type
5946 EXPR_VARIABLE and used it as rhs for the assignment. The
5947 advantage is, that we get scalarizer support for free,
5948 don't have to take care about scalar to array treatment and
5949 will benefit of every enhancements gfc_trans_assignment ()
5951 No need to check whether e3_is is E3_UNSET, because that is
5952 done by expr3 != NULL_TREE.
5953 Exclude variables since the following block does not handle
5954 array sections. In any case, there is no harm in sending
5955 variables to gfc_trans_assignment because there is no
5956 evaluation of variables. */
5959 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
5960 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
5961 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5963 /* Build a temporary symtree and symbol. Do not add it to the current
5964 namespace to prevent accidently modifying a colliding
5966 newsym
= XCNEW (gfc_symtree
);
5967 /* The name of the symtree should be unique, because gfc_create_var ()
5968 took care about generating the identifier. */
5970 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
5971 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5972 /* The backend_decl is known. It is expr3, which is inserted
5974 newsym
->n
.sym
->backend_decl
= expr3
;
5975 e3rhs
= gfc_get_expr ();
5976 e3rhs
->rank
= code
->expr3
->rank
;
5977 e3rhs
->symtree
= newsym
;
5978 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
5979 newsym
->n
.sym
->attr
.referenced
= 1;
5980 e3rhs
->expr_type
= EXPR_VARIABLE
;
5981 e3rhs
->where
= code
->expr3
->where
;
5982 /* Set the symbols type, upto it was BT_UNKNOWN. */
5983 if (IS_CLASS_ARRAY (code
->expr3
)
5984 && code
->expr3
->expr_type
== EXPR_FUNCTION
5985 && code
->expr3
->value
.function
.isym
5986 && code
->expr3
->value
.function
.isym
->transformational
)
5988 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5990 else if (code
->expr3
->ts
.type
== BT_CLASS
5991 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
5992 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5994 e3rhs
->ts
= code
->expr3
->ts
;
5995 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5996 /* Check whether the expr3 is array valued. */
5999 gfc_array_spec
*arr
;
6000 arr
= gfc_get_array_spec ();
6001 arr
->rank
= e3rhs
->rank
;
6002 arr
->type
= AS_DEFERRED
;
6003 /* Set the dimension and pointer attribute for arrays
6004 to be on the safe side. */
6005 newsym
->n
.sym
->attr
.dimension
= 1;
6006 newsym
->n
.sym
->attr
.pointer
= 1;
6007 newsym
->n
.sym
->as
= arr
;
6008 if (IS_CLASS_ARRAY (code
->expr3
)
6009 && code
->expr3
->expr_type
== EXPR_FUNCTION
6010 && code
->expr3
->value
.function
.isym
6011 && code
->expr3
->value
.function
.isym
->transformational
)
6013 gfc_array_spec
*tarr
;
6014 tarr
= gfc_get_array_spec ();
6016 e3rhs
->ts
.u
.derived
->as
= tarr
;
6018 gfc_add_full_array_ref (e3rhs
, arr
);
6020 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
6021 newsym
->n
.sym
->attr
.pointer
= 1;
6022 /* The string length is known, too. Set it for char arrays. */
6023 if (e3rhs
->ts
.type
== BT_CHARACTER
)
6024 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
6025 gfc_commit_symbol (newsym
->n
.sym
);
6028 e3rhs
= gfc_copy_expr (code
->expr3
);
6031 /* Loop over all objects to allocate. */
6032 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6034 expr
= gfc_copy_expr (al
->expr
);
6035 /* UNLIMITED_POLY () needs the _data component to be set, when
6036 expr is a unlimited polymorphic object. But the _data component
6037 has not been set yet, so check the derived type's attr for the
6038 unlimited polymorphic flag to be safe. */
6039 upoly_expr
= UNLIMITED_POLY (expr
)
6040 || (expr
->ts
.type
== BT_DERIVED
6041 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
6042 gfc_init_se (&se
, NULL
);
6044 /* For class types prepare the expressions to ref the _vptr
6045 and the _len component. The latter for unlimited polymorphic
6047 if (expr
->ts
.type
== BT_CLASS
)
6049 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
6050 gfc_add_data_component (expr
);
6051 /* Prep the vptr handle. */
6052 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
6053 gfc_add_vptr_component (expr_ref_vptr
);
6054 se
.want_pointer
= 1;
6055 gfc_conv_expr (&se
, expr_ref_vptr
);
6057 se
.want_pointer
= 0;
6058 gfc_free_expr (expr_ref_vptr
);
6059 /* Allocated unlimited polymorphic objects always have a _len
6063 expr_ref_len
= gfc_copy_expr (al
->expr
);
6064 gfc_add_len_component (expr_ref_len
);
6065 gfc_conv_expr (&se
, expr_ref_len
);
6067 gfc_free_expr (expr_ref_len
);
6070 /* In a loop ensure that all loop variable dependent variables
6071 are initialized at the same spot in all execution paths. */
6075 al_vptr
= al_len
= NULL_TREE
;
6077 se
.want_pointer
= 1;
6078 se
.descriptor_only
= 1;
6080 gfc_conv_expr (&se
, expr
);
6081 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6082 /* se.string_length now stores the .string_length variable of expr
6083 needed to allocate character(len=:) arrays. */
6084 al_len
= se
.string_length
;
6086 al_len_needs_set
= al_len
!= NULL_TREE
;
6087 /* When allocating an array one can not use much of the
6088 pre-evaluated expr3 expressions, because for most of them the
6089 scalarizer is needed which is not available in the pre-evaluation
6090 step. Therefore gfc_array_allocate () is responsible (and able)
6091 to handle the complete array allocation. Only the element size
6092 needs to be provided, which is done most of the time by the
6093 pre-evaluation step. */
6095 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6096 || code
->expr3
->ts
.type
== BT_CLASS
))
6098 /* When al is an array, then the element size for each element
6099 in the array is needed, which is the product of the len and
6100 esize for char arrays. For unlimited polymorphics len can be
6101 zero, therefore take the maximum of len and one. */
6102 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6103 TREE_TYPE (expr3_len
),
6104 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6106 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6107 TREE_TYPE (expr3_esize
), expr3_esize
,
6108 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6112 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6113 label_finish
, tmp
, &nelems
,
6114 e3rhs
? e3rhs
: code
->expr3
,
6115 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6116 code
->expr3
!= NULL
&& e3_is
== E3_DESC
6117 && code
->expr3
->expr_type
== EXPR_ARRAY
))
6119 /* A scalar or derived type. First compute the size to
6122 expr3_len is set when expr3 is an unlimited polymorphic
6123 object or a deferred length string. */
6124 if (expr3_len
!= NULL_TREE
)
6126 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6127 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6128 TREE_TYPE (expr3_esize
),
6130 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6131 /* expr3 is a deferred length string, i.e., we are
6136 /* For unlimited polymorphic enties build
6137 (len > 0) ? element_size * len : element_size
6138 to compute the number of bytes to allocate.
6139 This allows the allocation of unlimited polymorphic
6140 objects from an expr3 that is also unlimited
6141 polymorphic and stores a _len dependent object,
6143 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6144 logical_type_node
, expr3_len
,
6146 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6147 TREE_TYPE (expr3_esize
),
6148 memsz
, tmp
, expr3_esize
);
6151 else if (expr3_esize
!= NULL_TREE
)
6152 /* Any other object in expr3 just needs element size in
6154 memsz
= expr3_esize
;
6155 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6157 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6159 /* Allocating deferred length char arrays need the length
6160 to allocate in the alloc_type_spec. But also unlimited
6161 polymorphic objects may be allocated as char arrays.
6162 Both are handled here. */
6163 gfc_init_se (&se_sz
, NULL
);
6164 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6165 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6166 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6167 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6168 expr3_len
= se_sz
.expr
;
6169 tmp_expr3_len_flag
= true;
6170 tmp
= TYPE_SIZE_UNIT (
6171 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6172 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6174 fold_convert (TREE_TYPE (tmp
),
6178 else if (expr
->ts
.type
== BT_CHARACTER
)
6180 /* Compute the number of bytes needed to allocate a fixed
6181 length char array. */
6182 gcc_assert (se
.string_length
!= NULL_TREE
);
6183 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6184 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6185 TREE_TYPE (tmp
), tmp
,
6186 fold_convert (TREE_TYPE (tmp
),
6189 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6190 /* Handle all types, where the alloc_type_spec is set. */
6191 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6193 /* Handle size computation of the type declared to alloc. */
6194 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6196 /* Store the caf-attributes for latter use. */
6197 if (flag_coarray
== GFC_FCOARRAY_LIB
6198 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6201 /* Scalar allocatable components in coarray'ed derived types make
6202 it here and are treated now. */
6203 tree caf_decl
, token
;
6207 /* Set flag, to add synchronize after the allocate. */
6208 needs_caf_sync
= needs_caf_sync
6209 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6211 gfc_init_se (&caf_se
, NULL
);
6213 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6214 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6216 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6217 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6218 gfc_build_addr_expr (NULL_TREE
, token
),
6219 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6220 label_finish
, expr
, 1);
6222 /* Allocate - for non-pointers with re-alloc checking. */
6223 else if (gfc_expr_attr (expr
).allocatable
)
6224 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6225 NULL_TREE
, stat
, errmsg
, errlen
,
6226 label_finish
, expr
, 0);
6228 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6232 /* Allocating coarrays needs a sync after the allocate executed.
6233 Set the flag to add the sync after all objects are allocated. */
6234 if (flag_coarray
== GFC_FCOARRAY_LIB
6235 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6239 needs_caf_sync
= needs_caf_sync
6240 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6243 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6244 && expr3_len
!= NULL_TREE
)
6246 /* Arrays need to have a _len set before the array
6247 descriptor is filled. */
6248 gfc_add_modify (&block
, al_len
,
6249 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6250 /* Prevent setting the length twice. */
6251 al_len_needs_set
= false;
6253 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6254 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6256 /* Cover the cases where a string length is explicitly
6257 specified by a type spec for deferred length character
6258 arrays or unlimited polymorphic objects without a
6259 source= or mold= expression. */
6260 gfc_init_se (&se_sz
, NULL
);
6261 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6262 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6263 gfc_add_modify (&block
, al_len
,
6264 fold_convert (TREE_TYPE (al_len
),
6266 al_len_needs_set
= false;
6270 gfc_add_block_to_block (&block
, &se
.pre
);
6272 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6275 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6276 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6277 logical_type_node
, stat
,
6278 build_int_cst (TREE_TYPE (stat
), 0));
6279 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6280 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6281 tmp
, build_empty_stmt (input_location
));
6282 gfc_add_expr_to_block (&block
, tmp
);
6285 /* Set the vptr only when no source= is set. When source= is set, then
6286 the trans_assignment below will set the vptr. */
6287 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6289 if (expr3_vptr
!= NULL_TREE
)
6290 /* The vtab is already known, so just assign it. */
6291 gfc_add_modify (&block
, al_vptr
,
6292 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6295 /* VPTR is fixed at compile time. */
6300 /* Although expr3 is pre-evaluated above, it may happen,
6301 that for arrays or in mold= cases the pre-evaluation
6302 was not successful. In these rare cases take the vtab
6303 from the typespec of expr3 here. */
6304 ts
= &code
->expr3
->ts
;
6305 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6306 /* The alloc_type_spec gives the type to allocate or the
6307 al is unlimited polymorphic, which enforces the use of
6308 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6309 ts
= &code
->ext
.alloc
.ts
;
6311 /* Prepare for setting the vtab as declared. */
6314 vtab
= gfc_find_vtab (ts
);
6316 tmp
= gfc_build_addr_expr (NULL_TREE
,
6317 gfc_get_symbol_decl (vtab
));
6318 gfc_add_modify (&block
, al_vptr
,
6319 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6323 /* Add assignment for string length. */
6324 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6326 if (expr3_len
!= NULL_TREE
)
6328 gfc_add_modify (&block
, al_len
,
6329 fold_convert (TREE_TYPE (al_len
),
6331 /* When tmp_expr3_len_flag is set, then expr3_len is
6332 abused to carry the length information from the
6333 alloc_type. Clear it to prevent setting incorrect len
6334 information in future loop iterations. */
6335 if (tmp_expr3_len_flag
)
6336 /* No need to reset tmp_expr3_len_flag, because the
6337 presence of an expr3 can not change within in the
6339 expr3_len
= NULL_TREE
;
6341 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6342 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6344 /* Cover the cases where a string length is explicitly
6345 specified by a type spec for deferred length character
6346 arrays or unlimited polymorphic objects without a
6347 source= or mold= expression. */
6348 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6350 gfc_init_se (&se_sz
, NULL
);
6351 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6352 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6353 gfc_add_modify (&block
, al_len
,
6354 fold_convert (TREE_TYPE (al_len
),
6358 gfc_add_modify (&block
, al_len
,
6359 fold_convert (TREE_TYPE (al_len
),
6363 /* No length information needed, because type to allocate
6364 has no length. Set _len to 0. */
6365 gfc_add_modify (&block
, al_len
,
6366 fold_convert (TREE_TYPE (al_len
),
6367 integer_zero_node
));
6371 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6373 /* Initialization via SOURCE block (or static default initializer).
6374 Switch off automatic reallocation since we have just done the
6376 int realloc_lhs
= flag_realloc_lhs
;
6377 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6378 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6379 flag_realloc_lhs
= 0;
6380 tmp
= gfc_trans_assignment (init_expr
, rhs
, false, false, true,
6382 flag_realloc_lhs
= realloc_lhs
;
6383 /* Free the expression allocated for init_expr. */
6384 gfc_free_expr (init_expr
);
6386 gfc_free_expr (rhs
);
6387 gfc_add_expr_to_block (&block
, tmp
);
6389 /* Set KIND and LEN PDT components and allocate those that are
6391 else if (expr
->ts
.type
== BT_DERIVED
6392 && expr
->ts
.u
.derived
->attr
.pdt_type
)
6394 if (code
->expr3
&& code
->expr3
->param_list
)
6395 param_list
= code
->expr3
->param_list
;
6396 else if (expr
->param_list
)
6397 param_list
= expr
->param_list
;
6399 param_list
= expr
->symtree
->n
.sym
->param_list
;
6400 tmp
= gfc_allocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
,
6401 expr
->rank
, param_list
);
6402 gfc_add_expr_to_block (&block
, tmp
);
6404 /* Ditto for CLASS expressions. */
6405 else if (expr
->ts
.type
== BT_CLASS
6406 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
)
6408 if (code
->expr3
&& code
->expr3
->param_list
)
6409 param_list
= code
->expr3
->param_list
;
6410 else if (expr
->param_list
)
6411 param_list
= expr
->param_list
;
6413 param_list
= expr
->symtree
->n
.sym
->param_list
;
6414 tmp
= gfc_allocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6415 se
.expr
, expr
->rank
, param_list
);
6416 gfc_add_expr_to_block (&block
, tmp
);
6418 else if (code
->expr3
&& code
->expr3
->mold
6419 && code
->expr3
->ts
.type
== BT_CLASS
)
6421 /* Use class_init_assign to initialize expr. */
6423 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6424 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
);
6425 tmp
= gfc_trans_class_init_assign (ini
);
6426 gfc_free_statements (ini
);
6427 gfc_add_expr_to_block (&block
, tmp
);
6429 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
6431 /* Use class_init_assign to initialize expr. */
6433 int realloc_lhs
= flag_realloc_lhs
;
6434 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6435 ini
->expr1
= gfc_expr_to_initialize (expr
);
6436 ini
->expr2
= init_expr
;
6437 flag_realloc_lhs
= 0;
6438 tmp
= gfc_trans_init_assign (ini
);
6439 flag_realloc_lhs
= realloc_lhs
;
6440 gfc_free_statements (ini
);
6441 /* Init_expr is freeed by above free_statements, just need to null
6444 gfc_add_expr_to_block (&block
, tmp
);
6447 /* Nullify all pointers in derived type coarrays. This registers a
6448 token for them which allows their allocation. */
6451 gfc_symbol
*type
= NULL
;
6452 symbol_attribute caf_attr
;
6454 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6455 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
6457 type
= code
->ext
.alloc
.ts
.u
.derived
;
6458 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
6459 gfc_clear_attr (&caf_attr
);
6461 else if (expr
->ts
.type
== BT_DERIVED
6462 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
6464 type
= expr
->ts
.u
.derived
;
6466 caf_attr
= gfc_caf_attr (expr
, true);
6469 /* Initialize the tokens of pointer components in derived type
6473 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
6474 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
6475 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
6476 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
6477 gfc_add_expr_to_block (&block
, tmp
);
6481 gfc_free_expr (expr
);
6488 gfc_free_symbol (newsym
->n
.sym
);
6491 gfc_free_expr (e3rhs
);
6496 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6497 gfc_add_expr_to_block (&block
, tmp
);
6500 /* ERRMSG - only useful if STAT is present. */
6501 if (code
->expr1
&& code
->expr2
)
6503 const char *msg
= "Attempt to allocate an allocated object";
6504 tree slen
, dlen
, errmsg_str
;
6505 stmtblock_t errmsg_block
;
6507 gfc_init_block (&errmsg_block
);
6509 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6510 gfc_add_modify (&errmsg_block
, errmsg_str
,
6511 gfc_build_addr_expr (pchar_type_node
,
6512 gfc_build_localized_cstring_const (msg
)));
6514 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6515 dlen
= gfc_get_expr_charlen (code
->expr2
);
6516 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6517 TREE_TYPE (slen
), dlen
, slen
);
6519 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6520 code
->expr2
->ts
.kind
,
6522 gfc_default_character_kind
);
6523 dlen
= gfc_finish_block (&errmsg_block
);
6525 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6526 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6528 tmp
= build3_v (COND_EXPR
, tmp
,
6529 dlen
, build_empty_stmt (input_location
));
6531 gfc_add_expr_to_block (&block
, tmp
);
6537 if (TREE_USED (label_finish
))
6539 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6540 gfc_add_expr_to_block (&block
, tmp
);
6543 gfc_init_se (&se
, NULL
);
6544 gfc_conv_expr_lhs (&se
, code
->expr1
);
6545 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6546 gfc_add_modify (&block
, se
.expr
, tmp
);
6551 /* Add a sync all after the allocation has been executed. */
6552 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
6553 3, null_pointer_node
, null_pointer_node
,
6555 gfc_add_expr_to_block (&post
, tmp
);
6558 gfc_add_block_to_block (&block
, &se
.post
);
6559 gfc_add_block_to_block (&block
, &post
);
6561 return gfc_finish_block (&block
);
6565 /* Translate a DEALLOCATE statement. */
6568 gfc_trans_deallocate (gfc_code
*code
)
6572 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6573 tree label_finish
, label_errmsg
;
6576 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6577 label_finish
= label_errmsg
= NULL_TREE
;
6579 gfc_start_block (&block
);
6581 /* Count the number of failed deallocations. If deallocate() was
6582 called with STAT= , then set STAT to the count. If deallocate
6583 was called with ERRMSG, then set ERRMG to a string. */
6586 tree gfc_int4_type_node
= gfc_get_int_type (4);
6588 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6589 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6591 /* GOTO destinations. */
6592 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6593 label_finish
= gfc_build_label_decl (NULL_TREE
);
6594 TREE_USED (label_finish
) = 0;
6597 /* Set ERRMSG - only needed if STAT is available. */
6598 if (code
->expr1
&& code
->expr2
)
6600 gfc_init_se (&se
, NULL
);
6601 se
.want_pointer
= 1;
6602 gfc_conv_expr_lhs (&se
, code
->expr2
);
6604 errlen
= se
.string_length
;
6607 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6609 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6610 bool is_coarray
= false, is_coarray_array
= false;
6613 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6615 if (expr
->ts
.type
== BT_CLASS
)
6616 gfc_add_data_component (expr
);
6618 gfc_init_se (&se
, NULL
);
6619 gfc_start_block (&se
.pre
);
6621 se
.want_pointer
= 1;
6622 se
.descriptor_only
= 1;
6623 gfc_conv_expr (&se
, expr
);
6625 /* Deallocate PDT components that are parameterized. */
6627 if (expr
->ts
.type
== BT_DERIVED
6628 && expr
->ts
.u
.derived
->attr
.pdt_type
6629 && expr
->symtree
->n
.sym
->param_list
)
6630 tmp
= gfc_deallocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
, expr
->rank
);
6631 else if (expr
->ts
.type
== BT_CLASS
6632 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
6633 && expr
->symtree
->n
.sym
->param_list
)
6634 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6635 se
.expr
, expr
->rank
);
6638 gfc_add_expr_to_block (&block
, tmp
);
6640 if (flag_coarray
== GFC_FCOARRAY_LIB
6641 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
6644 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
6645 if (caf_attr
.codimension
)
6648 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
6649 || caf_attr
.coarray_comp
;
6651 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6652 /* When the expression to deallocate is referencing a
6653 component, then only deallocate it, but do not
6655 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
6656 | (comp_ref
&& !caf_attr
.coarray_comp
6657 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
6661 if (expr
->rank
|| is_coarray_array
)
6665 if (gfc_bt_struct (expr
->ts
.type
)
6666 && expr
->ts
.u
.derived
->attr
.alloc_comp
6667 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6669 gfc_ref
*last
= NULL
;
6671 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6672 if (ref
->type
== REF_COMPONENT
)
6675 /* Do not deallocate the components of a derived type
6676 ultimate pointer component. */
6677 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6678 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6680 if (is_coarray
&& expr
->rank
== 0
6681 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
6682 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6684 /* Add the ref to the data member only, when this is not
6685 a regular array or deallocate_alloc_comp will try to
6687 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
6691 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
6692 expr
->rank
, caf_mode
);
6693 gfc_add_expr_to_block (&se
.pre
, tmp
);
6697 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6699 gfc_coarray_deregtype caf_dtype
;
6702 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
6703 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
6704 : GFC_CAF_COARRAY_DEREGISTER
;
6706 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
6707 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
6708 label_finish
, false, expr
,
6710 gfc_add_expr_to_block (&se
.pre
, tmp
);
6712 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6713 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6714 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6717 /* class.c(finalize_component) generates these, when a
6718 finalizable entity has a non-allocatable derived type array
6719 component, which has allocatable components. Obtain the
6720 derived type of the array and deallocate the allocatable
6722 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6724 if (ref
->u
.c
.component
->attr
.dimension
6725 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6729 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6730 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6733 tmp
= gfc_deallocate_alloc_comp
6734 (ref
->u
.c
.component
->ts
.u
.derived
,
6735 se
.expr
, expr
->rank
);
6736 gfc_add_expr_to_block (&se
.pre
, tmp
);
6740 if (al
->expr
->ts
.type
== BT_CLASS
)
6742 gfc_reset_vptr (&se
.pre
, al
->expr
);
6743 if (UNLIMITED_POLY (al
->expr
)
6744 || (al
->expr
->ts
.type
== BT_DERIVED
6745 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6746 /* Clear _len, too. */
6747 gfc_reset_len (&se
.pre
, al
->expr
);
6752 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
6754 al
->expr
->ts
, is_coarray
);
6755 gfc_add_expr_to_block (&se
.pre
, tmp
);
6757 /* Set to zero after deallocation. */
6758 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6760 build_int_cst (TREE_TYPE (se
.expr
), 0));
6761 gfc_add_expr_to_block (&se
.pre
, tmp
);
6763 if (al
->expr
->ts
.type
== BT_CLASS
)
6765 gfc_reset_vptr (&se
.pre
, al
->expr
);
6766 if (UNLIMITED_POLY (al
->expr
)
6767 || (al
->expr
->ts
.type
== BT_DERIVED
6768 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6769 /* Clear _len, too. */
6770 gfc_reset_len (&se
.pre
, al
->expr
);
6778 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
6779 build_int_cst (TREE_TYPE (stat
), 0));
6780 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6781 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6782 build1_v (GOTO_EXPR
, label_errmsg
),
6783 build_empty_stmt (input_location
));
6784 gfc_add_expr_to_block (&se
.pre
, tmp
);
6787 tmp
= gfc_finish_block (&se
.pre
);
6788 gfc_add_expr_to_block (&block
, tmp
);
6789 gfc_free_expr (expr
);
6794 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6795 gfc_add_expr_to_block (&block
, tmp
);
6798 /* Set ERRMSG - only needed if STAT is available. */
6799 if (code
->expr1
&& code
->expr2
)
6801 const char *msg
= "Attempt to deallocate an unallocated object";
6802 stmtblock_t errmsg_block
;
6803 tree errmsg_str
, slen
, dlen
, cond
;
6805 gfc_init_block (&errmsg_block
);
6807 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6808 gfc_add_modify (&errmsg_block
, errmsg_str
,
6809 gfc_build_addr_expr (pchar_type_node
,
6810 gfc_build_localized_cstring_const (msg
)));
6811 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6812 dlen
= gfc_get_expr_charlen (code
->expr2
);
6814 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6815 slen
, errmsg_str
, gfc_default_character_kind
);
6816 tmp
= gfc_finish_block (&errmsg_block
);
6818 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
6819 build_int_cst (TREE_TYPE (stat
), 0));
6820 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6821 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6822 build_empty_stmt (input_location
));
6824 gfc_add_expr_to_block (&block
, tmp
);
6827 if (code
->expr1
&& TREE_USED (label_finish
))
6829 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6830 gfc_add_expr_to_block (&block
, tmp
);
6836 gfc_init_se (&se
, NULL
);
6837 gfc_conv_expr_lhs (&se
, code
->expr1
);
6838 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6839 gfc_add_modify (&block
, se
.expr
, tmp
);
6842 return gfc_finish_block (&block
);
6845 #include "gt-fortran-trans-stmt.h"