1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
30 #include "stringpool.h"
31 #include "fold-const.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
36 #include "dependency.h"
38 typedef struct iter_info
44 struct iter_info
*next
;
48 typedef struct forall_info
55 struct forall_info
*prev_nest
;
60 static void gfc_trans_where_2 (gfc_code
*, tree
, bool,
61 forall_info
*, stmtblock_t
*);
63 /* Translate a F95 label number to a LABEL_EXPR. */
66 gfc_trans_label_here (gfc_code
* code
)
68 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
72 /* Given a variable expression which has been ASSIGNed to, find the decl
73 containing the auxiliary variables. For variables in common blocks this
77 gfc_conv_label_variable (gfc_se
* se
, gfc_expr
* expr
)
79 gcc_assert (expr
->symtree
->n
.sym
->attr
.assign
== 1);
80 gfc_conv_expr (se
, expr
);
81 /* Deals with variable in common block. Get the field declaration. */
82 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
83 se
->expr
= TREE_OPERAND (se
->expr
, 1);
84 /* Deals with dummy argument. Get the parameter declaration. */
85 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
86 se
->expr
= TREE_OPERAND (se
->expr
, 0);
89 /* Translate a label assignment statement. */
92 gfc_trans_label_assign (gfc_code
* code
)
101 /* Start a new block. */
102 gfc_init_se (&se
, NULL
);
103 gfc_start_block (&se
.pre
);
104 gfc_conv_label_variable (&se
, code
->expr1
);
106 len
= GFC_DECL_STRING_LEN (se
.expr
);
107 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
109 label_tree
= gfc_get_label_decl (code
->label1
);
111 if (code
->label1
->defined
== ST_LABEL_TARGET
112 || code
->label1
->defined
== ST_LABEL_DO_TARGET
)
114 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
115 len_tree
= integer_minus_one_node
;
119 gfc_expr
*format
= code
->label1
->format
;
121 label_len
= format
->value
.character
.length
;
122 len_tree
= build_int_cst (gfc_charlen_type_node
, label_len
);
123 label_tree
= gfc_build_wide_string_const (format
->ts
.kind
, label_len
+ 1,
124 format
->value
.character
.string
);
125 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
128 gfc_add_modify (&se
.pre
, len
, len_tree
);
129 gfc_add_modify (&se
.pre
, addr
, label_tree
);
131 return gfc_finish_block (&se
.pre
);
134 /* Translate a GOTO statement. */
137 gfc_trans_goto (gfc_code
* code
)
139 locus loc
= code
->loc
;
145 if (code
->label1
!= NULL
)
146 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
149 gfc_init_se (&se
, NULL
);
150 gfc_start_block (&se
.pre
);
151 gfc_conv_label_variable (&se
, code
->expr1
);
152 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
153 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
154 build_int_cst (TREE_TYPE (tmp
), -1));
155 gfc_trans_runtime_check (true, false, tmp
, &se
.pre
, &loc
,
156 "Assigned label is not a target label");
158 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
160 /* We're going to ignore a label list. It does not really change the
161 statement's semantics (because it is just a further restriction on
162 what's legal code); before, we were comparing label addresses here, but
163 that's a very fragile business and may break with optimization. So
166 target
= fold_build1_loc (input_location
, GOTO_EXPR
, void_type_node
,
168 gfc_add_expr_to_block (&se
.pre
, target
);
169 return gfc_finish_block (&se
.pre
);
173 /* Translate an ENTRY statement. Just adds a label for this entry point. */
175 gfc_trans_entry (gfc_code
* code
)
177 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
181 /* Replace a gfc_ss structure by another both in the gfc_se struct
182 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
183 to replace a variable ss by the corresponding temporary. */
186 replace_ss (gfc_se
*se
, gfc_ss
*old_ss
, gfc_ss
*new_ss
)
188 gfc_ss
**sess
, **loopss
;
190 /* The old_ss is a ss for a single variable. */
191 gcc_assert (old_ss
->info
->type
== GFC_SS_SECTION
);
193 for (sess
= &(se
->ss
); *sess
!= gfc_ss_terminator
; sess
= &((*sess
)->next
))
196 gcc_assert (*sess
!= gfc_ss_terminator
);
199 new_ss
->next
= old_ss
->next
;
202 for (loopss
= &(se
->loop
->ss
); *loopss
!= gfc_ss_terminator
;
203 loopss
= &((*loopss
)->loop_chain
))
204 if (*loopss
== old_ss
)
206 gcc_assert (*loopss
!= gfc_ss_terminator
);
209 new_ss
->loop_chain
= old_ss
->loop_chain
;
210 new_ss
->loop
= old_ss
->loop
;
212 gfc_free_ss (old_ss
);
216 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
217 elemental subroutines. Make temporaries for output arguments if any such
218 dependencies are found. Output arguments are chosen because internal_unpack
219 can be used, as is, to copy the result back to the variable. */
221 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
222 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
223 gfc_dep_check check_variable
)
225 gfc_actual_arglist
*arg0
;
227 gfc_formal_arglist
*formal
;
235 if (loopse
->ss
== NULL
)
240 formal
= gfc_sym_get_dummy_args (sym
);
242 /* Loop over all the arguments testing for dependencies. */
243 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
249 /* Obtain the info structure for the current argument. */
250 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
251 if (ss
->info
->expr
== e
)
254 /* If there is a dependency, create a temporary and use it
255 instead of the variable. */
256 fsym
= formal
? formal
->sym
: NULL
;
257 if (e
->expr_type
== EXPR_VARIABLE
259 && fsym
->attr
.intent
!= INTENT_IN
260 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
261 sym
, arg0
, check_variable
))
263 tree initial
, temptype
;
264 stmtblock_t temp_post
;
267 tmp_ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, ss
->dimen
,
269 gfc_mark_ss_chain_used (tmp_ss
, 1);
270 tmp_ss
->info
->expr
= ss
->info
->expr
;
271 replace_ss (loopse
, ss
, tmp_ss
);
273 /* Obtain the argument descriptor for unpacking. */
274 gfc_init_se (&parmse
, NULL
);
275 parmse
.want_pointer
= 1;
276 gfc_conv_expr_descriptor (&parmse
, e
);
277 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
279 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
280 initialize the array temporary with a copy of the values. */
281 if (fsym
->attr
.intent
== INTENT_INOUT
282 || (fsym
->ts
.type
==BT_DERIVED
283 && fsym
->attr
.intent
== INTENT_OUT
))
284 initial
= parmse
.expr
;
285 /* For class expressions, we always initialize with the copy of
287 else if (e
->ts
.type
== BT_CLASS
)
288 initial
= parmse
.expr
;
292 if (e
->ts
.type
!= BT_CLASS
)
294 /* Find the type of the temporary to create; we don't use the type
295 of e itself as this breaks for subcomponent-references in e
296 (where the type of e is that of the final reference, but
297 parmse.expr's type corresponds to the full derived-type). */
298 /* TODO: Fix this somehow so we don't need a temporary of the whole
299 array but instead only the components referenced. */
300 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
301 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
302 temptype
= TREE_TYPE (temptype
);
303 temptype
= gfc_get_element_type (temptype
);
307 /* For class arrays signal that the size of the dynamic type has to
308 be obtained from the vtable, using the 'initial' expression. */
309 temptype
= NULL_TREE
;
311 /* Generate the temporary. Cleaning up the temporary should be the
312 very last thing done, so we add the code to a new block and add it
313 to se->post as last instructions. */
314 size
= gfc_create_var (gfc_array_index_type
, NULL
);
315 data
= gfc_create_var (pvoid_type_node
, NULL
);
316 gfc_init_block (&temp_post
);
317 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
, tmp_ss
,
318 temptype
, initial
, false, true,
319 false, &arg
->expr
->where
);
320 gfc_add_modify (&se
->pre
, size
, tmp
);
321 tmp
= fold_convert (pvoid_type_node
, tmp_ss
->info
->data
.array
.data
);
322 gfc_add_modify (&se
->pre
, data
, tmp
);
324 /* Update other ss' delta. */
325 gfc_set_delta (loopse
->loop
);
327 /* Copy the result back using unpack..... */
328 if (e
->ts
.type
!= BT_CLASS
)
329 tmp
= build_call_expr_loc (input_location
,
330 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
333 /* ... except for class results where the copy is
335 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
336 tmp
= gfc_conv_descriptor_data_get (tmp
);
337 tmp
= build_call_expr_loc (input_location
,
338 builtin_decl_explicit (BUILT_IN_MEMCPY
),
340 fold_convert (size_type_node
, size
));
342 gfc_add_expr_to_block (&se
->post
, tmp
);
344 /* parmse.pre is already added above. */
345 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
346 gfc_add_block_to_block (&se
->post
, &temp_post
);
352 /* Get the interface symbol for the procedure corresponding to the given call.
353 We can't get the procedure symbol directly as we have to handle the case
354 of (deferred) type-bound procedures. */
357 get_proc_ifc_for_call (gfc_code
*c
)
361 gcc_assert (c
->op
== EXEC_ASSIGN_CALL
|| c
->op
== EXEC_CALL
);
363 sym
= gfc_get_proc_ifc_for_expr (c
->expr1
);
365 /* Fall back/last resort try. */
367 sym
= c
->resolved_sym
;
373 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
376 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
377 tree mask
, tree count1
, bool invert
)
381 int has_alternate_specifier
;
382 gfc_dep_check check_variable
;
383 tree index
= NULL_TREE
;
384 tree maskexpr
= NULL_TREE
;
387 /* A CALL starts a new block because the actual arguments may have to
388 be evaluated first. */
389 gfc_init_se (&se
, NULL
);
390 gfc_start_block (&se
.pre
);
392 gcc_assert (code
->resolved_sym
);
394 ss
= gfc_ss_terminator
;
395 if (code
->resolved_sym
->attr
.elemental
)
396 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
,
397 get_proc_ifc_for_call (code
),
400 /* Is not an elemental subroutine call with array valued arguments. */
401 if (ss
== gfc_ss_terminator
)
404 /* Translate the call. */
405 has_alternate_specifier
406 = gfc_conv_procedure_call (&se
, code
->resolved_sym
, code
->ext
.actual
,
409 /* A subroutine without side-effect, by definition, does nothing! */
410 TREE_SIDE_EFFECTS (se
.expr
) = 1;
412 /* Chain the pieces together and return the block. */
413 if (has_alternate_specifier
)
415 gfc_code
*select_code
;
417 select_code
= code
->next
;
418 gcc_assert(select_code
->op
== EXEC_SELECT
);
419 sym
= select_code
->expr1
->symtree
->n
.sym
;
420 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
421 if (sym
->backend_decl
== NULL
)
422 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
423 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
426 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
428 gfc_add_block_to_block (&se
.pre
, &se
.post
);
433 /* An elemental subroutine call with array valued arguments has
441 /* gfc_walk_elemental_function_args renders the ss chain in the
442 reverse order to the actual argument order. */
443 ss
= gfc_reverse_ss (ss
);
445 /* Initialize the loop. */
446 gfc_init_se (&loopse
, NULL
);
447 gfc_init_loopinfo (&loop
);
448 gfc_add_ss_to_loop (&loop
, ss
);
450 gfc_conv_ss_startstride (&loop
);
451 /* TODO: gfc_conv_loop_setup generates a temporary for vector
452 subscripts. This could be prevented in the elemental case
453 as temporaries are handled separatedly
454 (below in gfc_conv_elemental_dependencies). */
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
, boolean_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
, boolean_type_node
,
1120 cond2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1122 build_int_cst (TREE_TYPE (images
), 1));
1123 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1124 boolean_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
, boolean_type_node
,
1419 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_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
, boolean_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;
1537 gcc_assert (sym
->assoc
);
1538 e
= sym
->assoc
->target
;
1540 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1541 && (gfc_is_class_scalar_expr (e
)
1542 || gfc_is_class_array_ref (e
, NULL
));
1544 unlimited
= UNLIMITED_POLY (e
);
1546 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1547 if (ref
->type
== REF_ARRAY
1548 && ref
->u
.ar
.type
== AR_FULL
1551 whole_array
= false;
1555 /* Assignments to the string length need to be generated, when
1556 ( sym is a char array or
1557 sym has a _len component)
1558 and the associated expression is unlimited polymorphic, which is
1559 not (yet) correctly in 'unlimited', because for an already associated
1560 BT_DERIVED the u-poly flag is not set, i.e.,
1561 __tmp_CHARACTER_0_1 => w => arg
1562 ^ generated temp ^ from code, the w does not have the u-poly
1563 flag set, where UNLIMITED_POLY(e) expects it. */
1564 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1565 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1566 && (sym
->ts
.type
== BT_CHARACTER
1567 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1568 && class_has_len_component (sym
))));
1569 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1570 to array temporary) for arrays with either unknown shape or if associating
1572 if (sym
->attr
.dimension
&& !class_target
1573 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1577 bool cst_array_ctor
;
1579 desc
= sym
->backend_decl
;
1580 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1581 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1583 /* If association is to an expression, evaluate it and create temporary.
1584 Otherwise, get descriptor of target for pointer assignment. */
1585 gfc_init_se (&se
, NULL
);
1586 if (sym
->assoc
->variable
|| cst_array_ctor
)
1588 se
.direct_byref
= 1;
1593 gfc_conv_expr_descriptor (&se
, e
);
1595 /* If we didn't already do the pointer assignment, set associate-name
1596 descriptor to the one generated for the temporary. */
1597 if ((!sym
->assoc
->variable
&& !cst_array_ctor
)
1603 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1605 /* The generated descriptor has lower bound zero (as array
1606 temporary), shift bounds so we get lower bounds of 1. */
1607 for (dim
= 0; dim
< e
->rank
; ++dim
)
1608 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1609 dim
, gfc_index_one_node
);
1612 /* If this is a subreference array pointer associate name use the
1613 associate variable element size for the value of 'span'. */
1614 if (sym
->attr
.subref_array_pointer
)
1616 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1617 tmp
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1618 ? gfc_class_data_get (e
->symtree
->n
.sym
->backend_decl
)
1619 : e
->symtree
->n
.sym
->backend_decl
;
1620 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1621 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1622 gfc_conv_descriptor_span_set (&se
.pre
, desc
, tmp
);
1625 /* Done, register stuff as init / cleanup code. */
1626 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1627 gfc_finish_block (&se
.post
));
1630 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1631 arrays to be assigned directly. */
1632 else if (class_target
&& sym
->attr
.dimension
1633 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1637 gfc_init_se (&se
, NULL
);
1638 se
.descriptor_only
= 1;
1639 /* In a select type the (temporary) associate variable shall point to
1640 a standard fortran array (lower bound == 1), but conv_expr ()
1641 just maps to the input array in the class object, whose lbound may
1642 be arbitrary. conv_expr_descriptor solves this by inserting a
1643 temporary array descriptor. */
1644 gfc_conv_expr_descriptor (&se
, e
);
1646 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1647 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1648 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1650 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1652 if (INDIRECT_REF_P (se
.expr
))
1653 tmp
= TREE_OPERAND (se
.expr
, 0);
1657 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1658 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1661 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1665 /* Recover the dtype, which has been overwritten by the
1666 assignment from an unlimited polymorphic object. */
1667 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1668 gfc_add_modify (&se
.pre
, tmp
,
1669 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1672 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1673 gfc_finish_block (&se
.post
));
1676 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1677 else if (gfc_is_associate_pointer (sym
))
1681 gcc_assert (!sym
->attr
.dimension
);
1683 gfc_init_se (&se
, NULL
);
1685 /* Class associate-names come this way because they are
1686 unconditionally associate pointers and the symbol is scalar. */
1687 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1690 /* For a class array we need a descriptor for the selector. */
1691 gfc_conv_expr_descriptor (&se
, e
);
1692 /* Needed to get/set the _len component below. */
1693 target_expr
= se
.expr
;
1695 /* Obtain a temporary class container for the result. */
1696 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1697 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1699 /* Set the offset. */
1700 desc
= gfc_class_data_get (se
.expr
);
1701 offset
= gfc_index_zero_node
;
1702 for (n
= 0; n
< e
->rank
; n
++)
1704 dim
= gfc_rank_cst
[n
];
1705 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1706 gfc_array_index_type
,
1707 gfc_conv_descriptor_stride_get (desc
, dim
),
1708 gfc_conv_descriptor_lbound_get (desc
, dim
));
1709 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1710 gfc_array_index_type
,
1713 if (need_len_assign
)
1716 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1717 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1718 /* Use the original class descriptor stored in the saved
1719 descriptor to get the target_expr. */
1721 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1723 /* Strip the _data component from the target_expr. */
1724 target_expr
= TREE_OPERAND (target_expr
, 0);
1725 /* Add a reference to the _len comp to the target expr. */
1726 tmp
= gfc_class_len_get (target_expr
);
1727 /* Get the component-ref for the temp structure's _len comp. */
1728 charlen
= gfc_class_len_get (se
.expr
);
1729 /* Add the assign to the beginning of the block... */
1730 gfc_add_modify (&se
.pre
, charlen
,
1731 fold_convert (TREE_TYPE (charlen
), tmp
));
1732 /* and the oposite way at the end of the block, to hand changes
1733 on the string length back. */
1734 gfc_add_modify (&se
.post
, tmp
,
1735 fold_convert (TREE_TYPE (tmp
), charlen
));
1736 /* Length assignment done, prevent adding it again below. */
1737 need_len_assign
= false;
1739 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1741 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1742 && CLASS_DATA (e
)->attr
.dimension
)
1744 /* This is bound to be a class array element. */
1745 gfc_conv_expr_reference (&se
, e
);
1746 /* Get the _vptr component of the class object. */
1747 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1748 /* Obtain a temporary class container for the result. */
1749 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1750 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1754 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1755 which has the string length included. For CHARACTERS it is still
1756 needed and will be done at the end of this routine. */
1757 gfc_conv_expr (&se
, e
);
1758 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1761 tmp
= TREE_TYPE (sym
->backend_decl
);
1762 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1763 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1765 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1766 gfc_finish_block (&se
.post
));
1769 /* Do a simple assignment. This is for scalar expressions, where we
1770 can simply use expression assignment. */
1775 lhs
= gfc_lval_expr_from_sym (sym
);
1776 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1777 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1780 /* Set the stringlength, when needed. */
1781 if (need_len_assign
)
1784 gfc_init_se (&se
, NULL
);
1785 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1787 /* What about deferred strings? */
1788 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1789 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1792 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1793 gfc_get_symbol_decl (sym
);
1794 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1795 : gfc_class_len_get (sym
->backend_decl
);
1796 /* Prevent adding a noop len= len. */
1799 gfc_add_modify (&se
.pre
, charlen
,
1800 fold_convert (TREE_TYPE (charlen
), tmp
));
1801 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1802 gfc_finish_block (&se
.post
));
1808 /* Translate a BLOCK construct. This is basically what we would do for a
1812 gfc_trans_block_construct (gfc_code
* code
)
1816 gfc_wrapped_block block
;
1819 gfc_association_list
*ass
;
1821 ns
= code
->ext
.block
.ns
;
1823 sym
= ns
->proc_name
;
1826 /* Process local variables. */
1827 gcc_assert (!sym
->tlink
);
1829 gfc_process_block_locals (ns
);
1831 /* Generate code including exit-label. */
1832 gfc_init_block (&body
);
1833 exit_label
= gfc_build_label_decl (NULL_TREE
);
1834 code
->exit_label
= exit_label
;
1836 finish_oacc_declare (ns
, sym
, true);
1838 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1839 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1841 /* Finish everything. */
1842 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1843 gfc_trans_deferred_vars (sym
, &block
);
1844 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1845 trans_associate_var (ass
->st
->n
.sym
, &block
);
1847 return gfc_finish_wrapped_block (&block
);
1850 /* Translate the simple DO construct in a C-style manner.
1851 This is where the loop variable has integer type and step +-1.
1852 Following code will generate infinite loop in case where TO is INT_MAX
1853 (for +1 step) or INT_MIN (for -1 step)
1855 We translate a do loop from:
1857 DO dovar = from, to, step
1863 [Evaluate loop bounds and step]
1875 This helps the optimizers by avoiding the extra pre-header condition and
1876 we save a register as we just compare the updated IV (not a value in
1880 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1881 tree from
, tree to
, tree step
, tree exit_cond
)
1887 tree saved_dovar
= NULL
;
1891 type
= TREE_TYPE (dovar
);
1892 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
1894 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1896 /* Initialize the DO variable: dovar = from. */
1897 gfc_add_modify_loc (loc
, pblock
, dovar
,
1898 fold_convert (TREE_TYPE (dovar
), from
));
1900 /* Save value for do-tinkering checking. */
1901 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1903 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1904 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1907 /* Cycle and exit statements are implemented with gotos. */
1908 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1909 exit_label
= gfc_build_label_decl (NULL_TREE
);
1911 /* Put the labels where they can be found later. See gfc_trans_do(). */
1912 code
->cycle_label
= cycle_label
;
1913 code
->exit_label
= exit_label
;
1916 gfc_start_block (&body
);
1918 /* Exit the loop if there is an I/O result condition or error. */
1921 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1922 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1924 build_empty_stmt (loc
));
1925 gfc_add_expr_to_block (&body
, tmp
);
1928 /* Evaluate the loop condition. */
1929 if (is_step_positive
)
1930 cond
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, dovar
,
1931 fold_convert (type
, to
));
1933 cond
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, dovar
,
1934 fold_convert (type
, to
));
1936 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1938 /* The loop exit. */
1939 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1940 TREE_USED (exit_label
) = 1;
1941 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1942 cond
, tmp
, build_empty_stmt (loc
));
1943 gfc_add_expr_to_block (&body
, tmp
);
1945 /* Check whether the induction variable is equal to INT_MAX
1946 (respectively to INT_MIN). */
1947 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1949 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
1950 : TYPE_MIN_VALUE (type
);
1952 tmp
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
,
1954 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1955 "Loop iterates infinitely");
1958 /* Main loop body. */
1959 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1960 gfc_add_expr_to_block (&body
, tmp
);
1962 /* Label for cycle statements (if needed). */
1963 if (TREE_USED (cycle_label
))
1965 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1966 gfc_add_expr_to_block (&body
, tmp
);
1969 /* Check whether someone has modified the loop variable. */
1970 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1972 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
1973 dovar
, saved_dovar
);
1974 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1975 "Loop variable has been modified");
1978 /* Increment the loop variable. */
1979 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1980 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1982 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1983 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1985 /* Finish the loop body. */
1986 tmp
= gfc_finish_block (&body
);
1987 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1989 gfc_add_expr_to_block (pblock
, tmp
);
1991 /* Add the exit label. */
1992 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1993 gfc_add_expr_to_block (pblock
, tmp
);
1995 return gfc_finish_block (pblock
);
1998 /* Translate the DO construct. This obviously is one of the most
1999 important ones to get right with any compiler, but especially
2002 We special case some loop forms as described in gfc_trans_simple_do.
2003 For other cases we implement them with a separate loop count,
2004 as described in the standard.
2006 We translate a do loop from:
2008 DO dovar = from, to, step
2014 [evaluate loop bounds and step]
2015 empty = (step > 0 ? to < from : to > from);
2016 countm1 = (to - from) / step;
2018 if (empty) goto exit_label;
2026 if (countm1t == 0) goto exit_label;
2030 countm1 is an unsigned integer. It is equal to the loop count minus one,
2031 because the loop count itself can overflow. */
2034 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2038 tree saved_dovar
= NULL
;
2053 gfc_start_block (&block
);
2055 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2057 /* Evaluate all the expressions in the iterator. */
2058 gfc_init_se (&se
, NULL
);
2059 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2060 gfc_add_block_to_block (&block
, &se
.pre
);
2062 type
= TREE_TYPE (dovar
);
2064 gfc_init_se (&se
, NULL
);
2065 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2066 gfc_add_block_to_block (&block
, &se
.pre
);
2067 from
= gfc_evaluate_now (se
.expr
, &block
);
2069 gfc_init_se (&se
, NULL
);
2070 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2071 gfc_add_block_to_block (&block
, &se
.pre
);
2072 to
= gfc_evaluate_now (se
.expr
, &block
);
2074 gfc_init_se (&se
, NULL
);
2075 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2076 gfc_add_block_to_block (&block
, &se
.pre
);
2077 step
= gfc_evaluate_now (se
.expr
, &block
);
2079 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2081 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
2082 build_zero_cst (type
));
2083 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2084 "DO step value is zero");
2087 /* Special case simple loops. */
2088 if (TREE_CODE (type
) == INTEGER_TYPE
2089 && (integer_onep (step
)
2090 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2091 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2094 if (TREE_CODE (type
) == INTEGER_TYPE
)
2095 utype
= unsigned_type_for (type
);
2097 utype
= unsigned_type_for (gfc_array_index_type
);
2098 countm1
= gfc_create_var (utype
, "countm1");
2100 /* Cycle and exit statements are implemented with gotos. */
2101 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2102 exit_label
= gfc_build_label_decl (NULL_TREE
);
2103 TREE_USED (exit_label
) = 1;
2105 /* Put these labels where they can be found later. */
2106 code
->cycle_label
= cycle_label
;
2107 code
->exit_label
= exit_label
;
2109 /* Initialize the DO variable: dovar = from. */
2110 gfc_add_modify (&block
, dovar
, from
);
2112 /* Save value for do-tinkering checking. */
2113 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2115 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2116 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2119 /* Initialize loop count and jump to exit label if the loop is empty.
2120 This code is executed before we enter the loop body. We generate:
2123 countm1 = (to - from) / step;
2129 countm1 = (from - to) / -step;
2135 if (TREE_CODE (type
) == INTEGER_TYPE
)
2137 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2139 /* The distance from FROM to TO cannot always be represented in a signed
2140 type, thus use unsigned arithmetic, also to avoid any undefined
2142 tou
= fold_convert (utype
, to
);
2143 fromu
= fold_convert (utype
, from
);
2144 stepu
= fold_convert (utype
, step
);
2146 /* For a positive step, when to < from, exit, otherwise compute
2147 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2148 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
2149 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2150 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2153 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2154 fold_build2 (MODIFY_EXPR
, void_type_node
,
2156 build3_loc (loc
, COND_EXPR
, void_type_node
,
2157 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2158 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2159 exit_label
), NULL_TREE
));
2161 /* For a negative step, when to > from, exit, otherwise compute
2162 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2163 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
2164 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2165 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2167 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2168 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2169 fold_build2 (MODIFY_EXPR
, void_type_node
,
2171 build3_loc (loc
, COND_EXPR
, void_type_node
,
2172 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2173 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2174 exit_label
), NULL_TREE
));
2176 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
2177 build_int_cst (TREE_TYPE (step
), 0));
2178 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2180 gfc_add_expr_to_block (&block
, tmp
);
2186 /* TODO: We could use the same width as the real type.
2187 This would probably cause more problems that it solves
2188 when we implement "long double" types. */
2190 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2191 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2192 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2193 gfc_add_modify (&block
, countm1
, tmp
);
2195 /* We need a special check for empty loops:
2196 empty = (step > 0 ? to < from : to > from); */
2197 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
2198 build_zero_cst (type
));
2199 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
2200 fold_build2_loc (loc
, LT_EXPR
,
2201 boolean_type_node
, to
, from
),
2202 fold_build2_loc (loc
, GT_EXPR
,
2203 boolean_type_node
, to
, from
));
2204 /* If the loop is empty, go directly to the exit label. */
2205 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2206 build1_v (GOTO_EXPR
, exit_label
),
2207 build_empty_stmt (input_location
));
2208 gfc_add_expr_to_block (&block
, tmp
);
2212 gfc_start_block (&body
);
2214 /* Main loop body. */
2215 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2216 gfc_add_expr_to_block (&body
, tmp
);
2218 /* Label for cycle statements (if needed). */
2219 if (TREE_USED (cycle_label
))
2221 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2222 gfc_add_expr_to_block (&body
, tmp
);
2225 /* Check whether someone has modified the loop variable. */
2226 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2228 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
2230 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2231 "Loop variable has been modified");
2234 /* Exit the loop if there is an I/O result condition or error. */
2237 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2238 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2240 build_empty_stmt (input_location
));
2241 gfc_add_expr_to_block (&body
, tmp
);
2244 /* Increment the loop variable. */
2245 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2246 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2248 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2249 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2251 /* Initialize countm1t. */
2252 tree countm1t
= gfc_create_var (utype
, "countm1t");
2253 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2255 /* Decrement the loop count. */
2256 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2257 build_int_cst (utype
, 1));
2258 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2260 /* End with the loop condition. Loop until countm1t == 0. */
2261 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
2262 build_int_cst (utype
, 0));
2263 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2264 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2265 cond
, tmp
, build_empty_stmt (loc
));
2266 gfc_add_expr_to_block (&body
, tmp
);
2268 /* End of loop body. */
2269 tmp
= gfc_finish_block (&body
);
2271 /* The for loop itself. */
2272 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2273 gfc_add_expr_to_block (&block
, tmp
);
2275 /* Add the exit label. */
2276 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2277 gfc_add_expr_to_block (&block
, tmp
);
2279 return gfc_finish_block (&block
);
2283 /* Translate the DO WHILE construct.
2296 if (! cond) goto exit_label;
2302 Because the evaluation of the exit condition `cond' may have side
2303 effects, we can't do much for empty loop bodies. The backend optimizers
2304 should be smart enough to eliminate any dead loops. */
2307 gfc_trans_do_while (gfc_code
* code
)
2315 /* Everything we build here is part of the loop body. */
2316 gfc_start_block (&block
);
2318 /* Cycle and exit statements are implemented with gotos. */
2319 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2320 exit_label
= gfc_build_label_decl (NULL_TREE
);
2322 /* Put the labels where they can be found later. See gfc_trans_do(). */
2323 code
->cycle_label
= cycle_label
;
2324 code
->exit_label
= exit_label
;
2326 /* Create a GIMPLE version of the exit condition. */
2327 gfc_init_se (&cond
, NULL
);
2328 gfc_conv_expr_val (&cond
, code
->expr1
);
2329 gfc_add_block_to_block (&block
, &cond
.pre
);
2330 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2331 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2333 /* Build "IF (! cond) GOTO exit_label". */
2334 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2335 TREE_USED (exit_label
) = 1;
2336 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2337 void_type_node
, cond
.expr
, tmp
,
2338 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2339 gfc_add_expr_to_block (&block
, tmp
);
2341 /* The main body of the loop. */
2342 tmp
= gfc_trans_code (code
->block
->next
);
2343 gfc_add_expr_to_block (&block
, tmp
);
2345 /* Label for cycle statements (if needed). */
2346 if (TREE_USED (cycle_label
))
2348 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2349 gfc_add_expr_to_block (&block
, tmp
);
2352 /* End of loop body. */
2353 tmp
= gfc_finish_block (&block
);
2355 gfc_init_block (&block
);
2356 /* Build the loop. */
2357 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2358 void_type_node
, tmp
);
2359 gfc_add_expr_to_block (&block
, tmp
);
2361 /* Add the exit label. */
2362 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2363 gfc_add_expr_to_block (&block
, tmp
);
2365 return gfc_finish_block (&block
);
2369 /* Deal with the particular case of SELECT_TYPE, where the vtable
2370 addresses are used for the selection. Since these are not sorted,
2371 the selection has to be made by a series of if statements. */
2374 gfc_trans_select_type_cases (gfc_code
* code
)
2388 gfc_start_block (&block
);
2390 /* Calculate the switch expression. */
2391 gfc_init_se (&se
, NULL
);
2392 gfc_conv_expr_val (&se
, code
->expr1
);
2393 gfc_add_block_to_block (&block
, &se
.pre
);
2395 /* Generate an expression for the selector hash value, for
2396 use to resolve character cases. */
2397 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2398 gfc_add_hash_component (e
);
2400 TREE_USED (code
->exit_label
) = 0;
2403 for (c
= code
->block
; c
; c
= c
->block
)
2405 cp
= c
->ext
.block
.case_list
;
2407 /* Assume it's the default case. */
2412 /* Put the default case at the end. */
2413 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2416 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2417 || cp
->ts
.type
== BT_DERIVED
))
2419 gfc_init_se (&cse
, NULL
);
2420 gfc_conv_expr_val (&cse
, cp
->low
);
2421 gfc_add_block_to_block (&block
, &cse
.pre
);
2424 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2426 gcc_assert (cp
->high
);
2427 gfc_init_se (&cse
, NULL
);
2428 gfc_conv_expr_val (&cse
, cp
->high
);
2429 gfc_add_block_to_block (&block
, &cse
.pre
);
2433 gfc_init_block (&body
);
2435 /* Add the statements for this case. */
2436 tmp
= gfc_trans_code (c
->next
);
2437 gfc_add_expr_to_block (&body
, tmp
);
2439 /* Break to the end of the SELECT TYPE construct. The default
2440 case just falls through. */
2443 TREE_USED (code
->exit_label
) = 1;
2444 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2445 gfc_add_expr_to_block (&body
, tmp
);
2448 tmp
= gfc_finish_block (&body
);
2450 if (low
!= NULL_TREE
)
2452 /* Compare vtable pointers. */
2453 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2454 TREE_TYPE (se
.expr
), se
.expr
, low
);
2455 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2457 build_empty_stmt (input_location
));
2459 else if (high
!= NULL_TREE
)
2461 /* Compare hash values for character cases. */
2462 gfc_init_se (&cse
, NULL
);
2463 gfc_conv_expr_val (&cse
, e
);
2464 gfc_add_block_to_block (&block
, &cse
.pre
);
2466 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2467 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2468 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2470 build_empty_stmt (input_location
));
2473 gfc_add_expr_to_block (&block
, tmp
);
2484 return gfc_finish_block (&block
);
2488 /* Translate the SELECT CASE construct for INTEGER case expressions,
2489 without killing all potential optimizations. The problem is that
2490 Fortran allows unbounded cases, but the back-end does not, so we
2491 need to intercept those before we enter the equivalent SWITCH_EXPR
2494 For example, we translate this,
2497 CASE (:100,101,105:115)
2507 to the GENERIC equivalent,
2511 case (minimum value for typeof(expr) ... 100:
2517 case 200 ... (maximum value for typeof(expr):
2534 gfc_trans_integer_select (gfc_code
* code
)
2544 gfc_start_block (&block
);
2546 /* Calculate the switch expression. */
2547 gfc_init_se (&se
, NULL
);
2548 gfc_conv_expr_val (&se
, code
->expr1
);
2549 gfc_add_block_to_block (&block
, &se
.pre
);
2551 end_label
= gfc_build_label_decl (NULL_TREE
);
2553 gfc_init_block (&body
);
2555 for (c
= code
->block
; c
; c
= c
->block
)
2557 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2562 /* Assume it's the default case. */
2563 low
= high
= NULL_TREE
;
2567 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2570 /* If there's only a lower bound, set the high bound to the
2571 maximum value of the case expression. */
2573 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2578 /* Three cases are possible here:
2580 1) There is no lower bound, e.g. CASE (:N).
2581 2) There is a lower bound .NE. high bound, that is
2582 a case range, e.g. CASE (N:M) where M>N (we make
2583 sure that M>N during type resolution).
2584 3) There is a lower bound, and it has the same value
2585 as the high bound, e.g. CASE (N:N). This is our
2586 internal representation of CASE(N).
2588 In the first and second case, we need to set a value for
2589 high. In the third case, we don't because the GCC middle
2590 end represents a single case value by just letting high be
2591 a NULL_TREE. We can't do that because we need to be able
2592 to represent unbounded cases. */
2595 || (mpz_cmp (cp
->low
->value
.integer
,
2596 cp
->high
->value
.integer
) != 0))
2597 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2600 /* Unbounded case. */
2602 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2605 /* Build a label. */
2606 label
= gfc_build_label_decl (NULL_TREE
);
2608 /* Add this case label.
2609 Add parameter 'label', make it match GCC backend. */
2610 tmp
= build_case_label (low
, high
, label
);
2611 gfc_add_expr_to_block (&body
, tmp
);
2614 /* Add the statements for this case. */
2615 tmp
= gfc_trans_code (c
->next
);
2616 gfc_add_expr_to_block (&body
, tmp
);
2618 /* Break to the end of the construct. */
2619 tmp
= build1_v (GOTO_EXPR
, end_label
);
2620 gfc_add_expr_to_block (&body
, tmp
);
2623 tmp
= gfc_finish_block (&body
);
2624 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2625 se
.expr
, tmp
, NULL_TREE
);
2626 gfc_add_expr_to_block (&block
, tmp
);
2628 tmp
= build1_v (LABEL_EXPR
, end_label
);
2629 gfc_add_expr_to_block (&block
, tmp
);
2631 return gfc_finish_block (&block
);
2635 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2637 There are only two cases possible here, even though the standard
2638 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2639 .FALSE., and DEFAULT.
2641 We never generate more than two blocks here. Instead, we always
2642 try to eliminate the DEFAULT case. This way, we can translate this
2643 kind of SELECT construct to a simple
2647 expression in GENERIC. */
2650 gfc_trans_logical_select (gfc_code
* code
)
2653 gfc_code
*t
, *f
, *d
;
2658 /* Assume we don't have any cases at all. */
2661 /* Now see which ones we actually do have. We can have at most two
2662 cases in a single case list: one for .TRUE. and one for .FALSE.
2663 The default case is always separate. If the cases for .TRUE. and
2664 .FALSE. are in the same case list, the block for that case list
2665 always executed, and we don't generate code a COND_EXPR. */
2666 for (c
= code
->block
; c
; c
= c
->block
)
2668 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2672 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2674 else /* if (cp->value.logical != 0), thus .TRUE. */
2682 /* Start a new block. */
2683 gfc_start_block (&block
);
2685 /* Calculate the switch expression. We always need to do this
2686 because it may have side effects. */
2687 gfc_init_se (&se
, NULL
);
2688 gfc_conv_expr_val (&se
, code
->expr1
);
2689 gfc_add_block_to_block (&block
, &se
.pre
);
2691 if (t
== f
&& t
!= NULL
)
2693 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2694 translate the code for these cases, append it to the current
2696 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2700 tree true_tree
, false_tree
, stmt
;
2702 true_tree
= build_empty_stmt (input_location
);
2703 false_tree
= build_empty_stmt (input_location
);
2705 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2706 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2707 make the missing case the default case. */
2708 if (t
!= NULL
&& f
!= NULL
)
2718 /* Translate the code for each of these blocks, and append it to
2719 the current block. */
2721 true_tree
= gfc_trans_code (t
->next
);
2724 false_tree
= gfc_trans_code (f
->next
);
2726 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2727 se
.expr
, true_tree
, false_tree
);
2728 gfc_add_expr_to_block (&block
, stmt
);
2731 return gfc_finish_block (&block
);
2735 /* The jump table types are stored in static variables to avoid
2736 constructing them from scratch every single time. */
2737 static GTY(()) tree select_struct
[2];
2739 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2740 Instead of generating compares and jumps, it is far simpler to
2741 generate a data structure describing the cases in order and call a
2742 library subroutine that locates the right case.
2743 This is particularly true because this is the only case where we
2744 might have to dispose of a temporary.
2745 The library subroutine returns a pointer to jump to or NULL if no
2746 branches are to be taken. */
2749 gfc_trans_character_select (gfc_code
*code
)
2751 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2752 stmtblock_t block
, body
;
2757 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2759 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2761 /* The jump table types are stored in static variables to avoid
2762 constructing them from scratch every single time. */
2763 static tree ss_string1
[2], ss_string1_len
[2];
2764 static tree ss_string2
[2], ss_string2_len
[2];
2765 static tree ss_target
[2];
2767 cp
= code
->block
->ext
.block
.case_list
;
2768 while (cp
->left
!= NULL
)
2771 /* Generate the body */
2772 gfc_start_block (&block
);
2773 gfc_init_se (&expr1se
, NULL
);
2774 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2776 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2778 end_label
= gfc_build_label_decl (NULL_TREE
);
2780 gfc_init_block (&body
);
2782 /* Attempt to optimize length 1 selects. */
2783 if (integer_onep (expr1se
.string_length
))
2785 for (d
= cp
; d
; d
= d
->right
)
2790 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2791 && d
->low
->ts
.type
== BT_CHARACTER
);
2792 if (d
->low
->value
.character
.length
> 1)
2794 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2795 if (d
->low
->value
.character
.string
[i
] != ' ')
2797 if (i
!= d
->low
->value
.character
.length
)
2799 if (optimize
&& d
->high
&& i
== 1)
2801 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2802 && d
->high
->ts
.type
== BT_CHARACTER
);
2803 if (d
->high
->value
.character
.length
> 1
2804 && (d
->low
->value
.character
.string
[0]
2805 == d
->high
->value
.character
.string
[0])
2806 && d
->high
->value
.character
.string
[1] != ' '
2807 && ((d
->low
->value
.character
.string
[1] < ' ')
2808 == (d
->high
->value
.character
.string
[1]
2818 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2819 && d
->high
->ts
.type
== BT_CHARACTER
);
2820 if (d
->high
->value
.character
.length
> 1)
2822 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2823 if (d
->high
->value
.character
.string
[i
] != ' ')
2825 if (i
!= d
->high
->value
.character
.length
)
2832 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2834 for (c
= code
->block
; c
; c
= c
->block
)
2836 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2842 /* Assume it's the default case. */
2843 low
= high
= NULL_TREE
;
2847 /* CASE ('ab') or CASE ('ab':'az') will never match
2848 any length 1 character. */
2849 if (cp
->low
->value
.character
.length
> 1
2850 && cp
->low
->value
.character
.string
[1] != ' ')
2853 if (cp
->low
->value
.character
.length
> 0)
2854 r
= cp
->low
->value
.character
.string
[0];
2857 low
= build_int_cst (ctype
, r
);
2859 /* If there's only a lower bound, set the high bound
2860 to the maximum value of the case expression. */
2862 high
= TYPE_MAX_VALUE (ctype
);
2868 || (cp
->low
->value
.character
.string
[0]
2869 != cp
->high
->value
.character
.string
[0]))
2871 if (cp
->high
->value
.character
.length
> 0)
2872 r
= cp
->high
->value
.character
.string
[0];
2875 high
= build_int_cst (ctype
, r
);
2878 /* Unbounded case. */
2880 low
= TYPE_MIN_VALUE (ctype
);
2883 /* Build a label. */
2884 label
= gfc_build_label_decl (NULL_TREE
);
2886 /* Add this case label.
2887 Add parameter 'label', make it match GCC backend. */
2888 tmp
= build_case_label (low
, high
, label
);
2889 gfc_add_expr_to_block (&body
, tmp
);
2892 /* Add the statements for this case. */
2893 tmp
= gfc_trans_code (c
->next
);
2894 gfc_add_expr_to_block (&body
, tmp
);
2896 /* Break to the end of the construct. */
2897 tmp
= build1_v (GOTO_EXPR
, end_label
);
2898 gfc_add_expr_to_block (&body
, tmp
);
2901 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2903 code
->expr1
->ts
.kind
);
2904 case_num
= gfc_create_var (ctype
, "case_num");
2905 gfc_add_modify (&block
, case_num
, tmp
);
2907 gfc_add_block_to_block (&block
, &expr1se
.post
);
2909 tmp
= gfc_finish_block (&body
);
2910 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2911 case_num
, tmp
, NULL_TREE
);
2912 gfc_add_expr_to_block (&block
, tmp
);
2914 tmp
= build1_v (LABEL_EXPR
, end_label
);
2915 gfc_add_expr_to_block (&block
, tmp
);
2917 return gfc_finish_block (&block
);
2921 if (code
->expr1
->ts
.kind
== 1)
2923 else if (code
->expr1
->ts
.kind
== 4)
2928 if (select_struct
[k
] == NULL
)
2931 select_struct
[k
] = make_node (RECORD_TYPE
);
2933 if (code
->expr1
->ts
.kind
== 1)
2934 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2935 else if (code
->expr1
->ts
.kind
== 4)
2936 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2941 #define ADD_FIELD(NAME, TYPE) \
2942 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2943 get_identifier (stringize(NAME)), \
2947 ADD_FIELD (string1
, pchartype
);
2948 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2950 ADD_FIELD (string2
, pchartype
);
2951 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2953 ADD_FIELD (target
, integer_type_node
);
2956 gfc_finish_type (select_struct
[k
]);
2960 for (d
= cp
; d
; d
= d
->right
)
2963 for (c
= code
->block
; c
; c
= c
->block
)
2965 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
2967 label
= gfc_build_label_decl (NULL_TREE
);
2968 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
2970 : build_int_cst (integer_type_node
, d
->n
),
2972 gfc_add_expr_to_block (&body
, tmp
);
2975 tmp
= gfc_trans_code (c
->next
);
2976 gfc_add_expr_to_block (&body
, tmp
);
2978 tmp
= build1_v (GOTO_EXPR
, end_label
);
2979 gfc_add_expr_to_block (&body
, tmp
);
2982 /* Generate the structure describing the branches */
2983 for (d
= cp
; d
; d
= d
->right
)
2985 vec
<constructor_elt
, va_gc
> *node
= NULL
;
2987 gfc_init_se (&se
, NULL
);
2991 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
2992 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
2996 gfc_conv_expr_reference (&se
, d
->low
);
2998 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
2999 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
3002 if (d
->high
== NULL
)
3004 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
3005 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
3009 gfc_init_se (&se
, NULL
);
3010 gfc_conv_expr_reference (&se
, d
->high
);
3012 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
3013 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
3016 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
3017 build_int_cst (integer_type_node
, d
->n
));
3019 tmp
= build_constructor (select_struct
[k
], node
);
3020 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
3023 type
= build_array_type (select_struct
[k
],
3024 build_index_type (size_int (n
-1)));
3026 init
= build_constructor (type
, inits
);
3027 TREE_CONSTANT (init
) = 1;
3028 TREE_STATIC (init
) = 1;
3029 /* Create a static variable to hold the jump table. */
3030 tmp
= gfc_create_var (type
, "jumptable");
3031 TREE_CONSTANT (tmp
) = 1;
3032 TREE_STATIC (tmp
) = 1;
3033 TREE_READONLY (tmp
) = 1;
3034 DECL_INITIAL (tmp
) = init
;
3037 /* Build the library call */
3038 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3040 if (code
->expr1
->ts
.kind
== 1)
3041 fndecl
= gfor_fndecl_select_string
;
3042 else if (code
->expr1
->ts
.kind
== 4)
3043 fndecl
= gfor_fndecl_select_string_char4
;
3047 tmp
= build_call_expr_loc (input_location
,
3049 build_int_cst (gfc_charlen_type_node
, n
),
3050 expr1se
.expr
, expr1se
.string_length
);
3051 case_num
= gfc_create_var (integer_type_node
, "case_num");
3052 gfc_add_modify (&block
, case_num
, tmp
);
3054 gfc_add_block_to_block (&block
, &expr1se
.post
);
3056 tmp
= gfc_finish_block (&body
);
3057 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3058 case_num
, tmp
, NULL_TREE
);
3059 gfc_add_expr_to_block (&block
, tmp
);
3061 tmp
= build1_v (LABEL_EXPR
, end_label
);
3062 gfc_add_expr_to_block (&block
, tmp
);
3064 return gfc_finish_block (&block
);
3068 /* Translate the three variants of the SELECT CASE construct.
3070 SELECT CASEs with INTEGER case expressions can be translated to an
3071 equivalent GENERIC switch statement, and for LOGICAL case
3072 expressions we build one or two if-else compares.
3074 SELECT CASEs with CHARACTER case expressions are a whole different
3075 story, because they don't exist in GENERIC. So we sort them and
3076 do a binary search at runtime.
3078 Fortran has no BREAK statement, and it does not allow jumps from
3079 one case block to another. That makes things a lot easier for
3083 gfc_trans_select (gfc_code
* code
)
3089 gcc_assert (code
&& code
->expr1
);
3090 gfc_init_block (&block
);
3092 /* Build the exit label and hang it in. */
3093 exit_label
= gfc_build_label_decl (NULL_TREE
);
3094 code
->exit_label
= exit_label
;
3096 /* Empty SELECT constructs are legal. */
3097 if (code
->block
== NULL
)
3098 body
= build_empty_stmt (input_location
);
3100 /* Select the correct translation function. */
3102 switch (code
->expr1
->ts
.type
)
3105 body
= gfc_trans_logical_select (code
);
3109 body
= gfc_trans_integer_select (code
);
3113 body
= gfc_trans_character_select (code
);
3117 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3121 /* Build everything together. */
3122 gfc_add_expr_to_block (&block
, body
);
3123 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3125 return gfc_finish_block (&block
);
3129 gfc_trans_select_type (gfc_code
* code
)
3135 gcc_assert (code
&& code
->expr1
);
3136 gfc_init_block (&block
);
3138 /* Build the exit label and hang it in. */
3139 exit_label
= gfc_build_label_decl (NULL_TREE
);
3140 code
->exit_label
= exit_label
;
3142 /* Empty SELECT constructs are legal. */
3143 if (code
->block
== NULL
)
3144 body
= build_empty_stmt (input_location
);
3146 body
= gfc_trans_select_type_cases (code
);
3148 /* Build everything together. */
3149 gfc_add_expr_to_block (&block
, body
);
3151 if (TREE_USED (exit_label
))
3152 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3154 return gfc_finish_block (&block
);
3158 /* Traversal function to substitute a replacement symtree if the symbol
3159 in the expression is the same as that passed. f == 2 signals that
3160 that variable itself is not to be checked - only the references.
3161 This group of functions is used when the variable expression in a
3162 FORALL assignment has internal references. For example:
3163 FORALL (i = 1:4) p(p(i)) = i
3164 The only recourse here is to store a copy of 'p' for the index
3167 static gfc_symtree
*new_symtree
;
3168 static gfc_symtree
*old_symtree
;
3171 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3173 if (expr
->expr_type
!= EXPR_VARIABLE
)
3178 else if (expr
->symtree
->n
.sym
== sym
)
3179 expr
->symtree
= new_symtree
;
3185 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3187 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3191 forall_restore (gfc_expr
*expr
,
3192 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3193 int *f ATTRIBUTE_UNUSED
)
3195 if (expr
->expr_type
!= EXPR_VARIABLE
)
3198 if (expr
->symtree
== new_symtree
)
3199 expr
->symtree
= old_symtree
;
3205 forall_restore_symtree (gfc_expr
*e
)
3207 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3211 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3216 gfc_symbol
*new_sym
;
3217 gfc_symbol
*old_sym
;
3221 /* Build a copy of the lvalue. */
3222 old_symtree
= c
->expr1
->symtree
;
3223 old_sym
= old_symtree
->n
.sym
;
3224 e
= gfc_lval_expr_from_sym (old_sym
);
3225 if (old_sym
->attr
.dimension
)
3227 gfc_init_se (&tse
, NULL
);
3228 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3229 gfc_add_block_to_block (pre
, &tse
.pre
);
3230 gfc_add_block_to_block (post
, &tse
.post
);
3231 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3233 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3235 /* Use the variable offset for the temporary. */
3236 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3237 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3242 gfc_init_se (&tse
, NULL
);
3243 gfc_init_se (&rse
, NULL
);
3244 gfc_conv_expr (&rse
, e
);
3245 if (e
->ts
.type
== BT_CHARACTER
)
3247 tse
.string_length
= rse
.string_length
;
3248 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3250 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3252 gfc_add_block_to_block (pre
, &tse
.pre
);
3253 gfc_add_block_to_block (post
, &tse
.post
);
3257 tmp
= gfc_typenode_for_spec (&e
->ts
);
3258 tse
.expr
= gfc_create_var (tmp
, "temp");
3261 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3262 e
->expr_type
== EXPR_VARIABLE
, false);
3263 gfc_add_expr_to_block (pre
, tmp
);
3267 /* Create a new symbol to represent the lvalue. */
3268 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3269 new_sym
->ts
= old_sym
->ts
;
3270 new_sym
->attr
.referenced
= 1;
3271 new_sym
->attr
.temporary
= 1;
3272 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3273 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3275 /* Use the temporary as the backend_decl. */
3276 new_sym
->backend_decl
= tse
.expr
;
3278 /* Create a fake symtree for it. */
3280 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3281 new_symtree
->n
.sym
= new_sym
;
3282 gcc_assert (new_symtree
== root
);
3284 /* Go through the expression reference replacing the old_symtree
3286 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3288 /* Now we have made this temporary, we might as well use it for
3289 the right hand side. */
3290 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3294 /* Handles dependencies in forall assignments. */
3296 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3303 lsym
= c
->expr1
->symtree
->n
.sym
;
3304 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3306 /* Now check for dependencies within the 'variable'
3307 expression itself. These are treated by making a complete
3308 copy of variable and changing all the references to it
3309 point to the copy instead. Note that the shallow copy of
3310 the variable will not suffice for derived types with
3311 pointer components. We therefore leave these to their
3313 if (lsym
->ts
.type
== BT_DERIVED
3314 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3318 if (find_forall_index (c
->expr1
, lsym
, 2))
3320 forall_make_variable_temp (c
, pre
, post
);
3324 /* Substrings with dependencies are treated in the same
3326 if (c
->expr1
->ts
.type
== BT_CHARACTER
3328 && c
->expr2
->expr_type
== EXPR_VARIABLE
3329 && lsym
== c
->expr2
->symtree
->n
.sym
)
3331 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3332 if (lref
->type
== REF_SUBSTRING
)
3334 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3335 if (rref
->type
== REF_SUBSTRING
)
3339 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3341 forall_make_variable_temp (c
, pre
, post
);
3350 cleanup_forall_symtrees (gfc_code
*c
)
3352 forall_restore_symtree (c
->expr1
);
3353 forall_restore_symtree (c
->expr2
);
3354 free (new_symtree
->n
.sym
);
3359 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3360 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3361 indicates whether we should generate code to test the FORALLs mask
3362 array. OUTER is the loop header to be used for initializing mask
3365 The generated loop format is:
3366 count = (end - start + step) / step
3379 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3380 int mask_flag
, stmtblock_t
*outer
)
3388 tree var
, start
, end
, step
;
3391 /* Initialize the mask index outside the FORALL nest. */
3392 if (mask_flag
&& forall_tmp
->mask
)
3393 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3395 iter
= forall_tmp
->this_loop
;
3396 nvar
= forall_tmp
->nvar
;
3397 for (n
= 0; n
< nvar
; n
++)
3400 start
= iter
->start
;
3404 exit_label
= gfc_build_label_decl (NULL_TREE
);
3405 TREE_USED (exit_label
) = 1;
3407 /* The loop counter. */
3408 count
= gfc_create_var (TREE_TYPE (var
), "count");
3410 /* The body of the loop. */
3411 gfc_init_block (&block
);
3413 /* The exit condition. */
3414 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3415 count
, build_int_cst (TREE_TYPE (count
), 0));
3416 if (forall_tmp
->do_concurrent
)
3417 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3418 build_int_cst (integer_type_node
,
3419 annot_expr_ivdep_kind
));
3421 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3422 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3423 cond
, tmp
, build_empty_stmt (input_location
));
3424 gfc_add_expr_to_block (&block
, tmp
);
3426 /* The main loop body. */
3427 gfc_add_expr_to_block (&block
, body
);
3429 /* Increment the loop variable. */
3430 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3432 gfc_add_modify (&block
, var
, tmp
);
3434 /* Advance to the next mask element. Only do this for the
3436 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3438 tree maskindex
= forall_tmp
->maskindex
;
3439 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3440 maskindex
, gfc_index_one_node
);
3441 gfc_add_modify (&block
, maskindex
, tmp
);
3444 /* Decrement the loop counter. */
3445 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3446 build_int_cst (TREE_TYPE (var
), 1));
3447 gfc_add_modify (&block
, count
, tmp
);
3449 body
= gfc_finish_block (&block
);
3451 /* Loop var initialization. */
3452 gfc_init_block (&block
);
3453 gfc_add_modify (&block
, var
, start
);
3456 /* Initialize the loop counter. */
3457 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3459 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3461 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3463 gfc_add_modify (&block
, count
, tmp
);
3465 /* The loop expression. */
3466 tmp
= build1_v (LOOP_EXPR
, body
);
3467 gfc_add_expr_to_block (&block
, tmp
);
3469 /* The exit label. */
3470 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3471 gfc_add_expr_to_block (&block
, tmp
);
3473 body
= gfc_finish_block (&block
);
3480 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3481 is nonzero, the body is controlled by all masks in the forall nest.
3482 Otherwise, the innermost loop is not controlled by it's mask. This
3483 is used for initializing that mask. */
3486 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3491 forall_info
*forall_tmp
;
3492 tree mask
, maskindex
;
3494 gfc_start_block (&header
);
3496 forall_tmp
= nested_forall_info
;
3497 while (forall_tmp
!= NULL
)
3499 /* Generate body with masks' control. */
3502 mask
= forall_tmp
->mask
;
3503 maskindex
= forall_tmp
->maskindex
;
3505 /* If a mask was specified make the assignment conditional. */
3508 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3509 body
= build3_v (COND_EXPR
, tmp
, body
,
3510 build_empty_stmt (input_location
));
3513 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3514 forall_tmp
= forall_tmp
->prev_nest
;
3518 gfc_add_expr_to_block (&header
, body
);
3519 return gfc_finish_block (&header
);
3523 /* Allocate data for holding a temporary array. Returns either a local
3524 temporary array or a pointer variable. */
3527 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3534 if (INTEGER_CST_P (size
))
3535 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3536 size
, gfc_index_one_node
);
3540 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3541 type
= build_array_type (elem_type
, type
);
3542 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3544 tmpvar
= gfc_create_var (type
, "temp");
3549 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3550 *pdata
= convert (pvoid_type_node
, tmpvar
);
3552 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3553 gfc_add_modify (pblock
, tmpvar
, tmp
);
3559 /* Generate codes to copy the temporary to the actual lhs. */
3562 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3564 gfc_ss
*lss
, gfc_ss
*rss
,
3565 tree wheremask
, bool invert
)
3567 stmtblock_t block
, body1
;
3574 (void) rss
; /* TODO: unused. */
3576 gfc_start_block (&block
);
3578 gfc_init_se (&rse
, NULL
);
3579 gfc_init_se (&lse
, NULL
);
3581 if (lss
== gfc_ss_terminator
)
3583 gfc_init_block (&body1
);
3584 gfc_conv_expr (&lse
, expr
);
3585 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3589 /* Initialize the loop. */
3590 gfc_init_loopinfo (&loop
);
3592 /* We may need LSS to determine the shape of the expression. */
3593 gfc_add_ss_to_loop (&loop
, lss
);
3595 gfc_conv_ss_startstride (&loop
);
3596 gfc_conv_loop_setup (&loop
, &expr
->where
);
3598 gfc_mark_ss_chain_used (lss
, 1);
3599 /* Start the loop body. */
3600 gfc_start_scalarized_body (&loop
, &body1
);
3602 /* Translate the expression. */
3603 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3605 gfc_conv_expr (&lse
, expr
);
3607 /* Form the expression of the temporary. */
3608 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3611 /* Use the scalar assignment. */
3612 rse
.string_length
= lse
.string_length
;
3613 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
3614 expr
->expr_type
== EXPR_VARIABLE
, false);
3616 /* Form the mask expression according to the mask tree list. */
3619 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3621 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3622 TREE_TYPE (wheremaskexpr
),
3624 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3626 build_empty_stmt (input_location
));
3629 gfc_add_expr_to_block (&body1
, tmp
);
3631 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3632 count1
, gfc_index_one_node
);
3633 gfc_add_modify (&body1
, count1
, tmp
);
3635 if (lss
== gfc_ss_terminator
)
3636 gfc_add_block_to_block (&block
, &body1
);
3639 /* Increment count3. */
3642 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3643 gfc_array_index_type
,
3644 count3
, gfc_index_one_node
);
3645 gfc_add_modify (&body1
, count3
, tmp
);
3648 /* Generate the copying loops. */
3649 gfc_trans_scalarizing_loops (&loop
, &body1
);
3651 gfc_add_block_to_block (&block
, &loop
.pre
);
3652 gfc_add_block_to_block (&block
, &loop
.post
);
3654 gfc_cleanup_loop (&loop
);
3655 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3656 as tree nodes in SS may not be valid in different scope. */
3659 tmp
= gfc_finish_block (&block
);
3664 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3665 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3666 and should not be freed. WHEREMASK is the conditional execution mask
3667 whose sense may be inverted by INVERT. */
3670 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3671 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3672 tree wheremask
, bool invert
)
3674 stmtblock_t block
, body1
;
3681 gfc_start_block (&block
);
3683 gfc_init_se (&rse
, NULL
);
3684 gfc_init_se (&lse
, NULL
);
3686 if (lss
== gfc_ss_terminator
)
3688 gfc_init_block (&body1
);
3689 gfc_conv_expr (&rse
, expr2
);
3690 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3694 /* Initialize the loop. */
3695 gfc_init_loopinfo (&loop
);
3697 /* We may need LSS to determine the shape of the expression. */
3698 gfc_add_ss_to_loop (&loop
, lss
);
3699 gfc_add_ss_to_loop (&loop
, rss
);
3701 gfc_conv_ss_startstride (&loop
);
3702 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3704 gfc_mark_ss_chain_used (rss
, 1);
3705 /* Start the loop body. */
3706 gfc_start_scalarized_body (&loop
, &body1
);
3708 /* Translate the expression. */
3709 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3711 gfc_conv_expr (&rse
, expr2
);
3713 /* Form the expression of the temporary. */
3714 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3717 /* Use the scalar assignment. */
3718 lse
.string_length
= rse
.string_length
;
3719 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3720 expr2
->expr_type
== EXPR_VARIABLE
, false);
3722 /* Form the mask expression according to the mask tree list. */
3725 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3727 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3728 TREE_TYPE (wheremaskexpr
),
3730 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3732 build_empty_stmt (input_location
));
3735 gfc_add_expr_to_block (&body1
, tmp
);
3737 if (lss
== gfc_ss_terminator
)
3739 gfc_add_block_to_block (&block
, &body1
);
3741 /* Increment count1. */
3742 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3743 count1
, gfc_index_one_node
);
3744 gfc_add_modify (&block
, count1
, tmp
);
3748 /* Increment count1. */
3749 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3750 count1
, gfc_index_one_node
);
3751 gfc_add_modify (&body1
, count1
, tmp
);
3753 /* Increment count3. */
3756 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3757 gfc_array_index_type
,
3758 count3
, gfc_index_one_node
);
3759 gfc_add_modify (&body1
, count3
, tmp
);
3762 /* Generate the copying loops. */
3763 gfc_trans_scalarizing_loops (&loop
, &body1
);
3765 gfc_add_block_to_block (&block
, &loop
.pre
);
3766 gfc_add_block_to_block (&block
, &loop
.post
);
3768 gfc_cleanup_loop (&loop
);
3769 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3770 as tree nodes in SS may not be valid in different scope. */
3773 tmp
= gfc_finish_block (&block
);
3778 /* Calculate the size of temporary needed in the assignment inside forall.
3779 LSS and RSS are filled in this function. */
3782 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3783 stmtblock_t
* pblock
,
3784 gfc_ss
**lss
, gfc_ss
**rss
)
3792 *lss
= gfc_walk_expr (expr1
);
3795 size
= gfc_index_one_node
;
3796 if (*lss
!= gfc_ss_terminator
)
3798 gfc_init_loopinfo (&loop
);
3800 /* Walk the RHS of the expression. */
3801 *rss
= gfc_walk_expr (expr2
);
3802 if (*rss
== gfc_ss_terminator
)
3803 /* The rhs is scalar. Add a ss for the expression. */
3804 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3806 /* Associate the SS with the loop. */
3807 gfc_add_ss_to_loop (&loop
, *lss
);
3808 /* We don't actually need to add the rhs at this point, but it might
3809 make guessing the loop bounds a bit easier. */
3810 gfc_add_ss_to_loop (&loop
, *rss
);
3812 /* We only want the shape of the expression, not rest of the junk
3813 generated by the scalarizer. */
3814 loop
.array_parameter
= 1;
3816 /* Calculate the bounds of the scalarization. */
3817 save_flag
= gfc_option
.rtcheck
;
3818 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3819 gfc_conv_ss_startstride (&loop
);
3820 gfc_option
.rtcheck
= save_flag
;
3821 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3823 /* Figure out how many elements we need. */
3824 for (i
= 0; i
< loop
.dimen
; i
++)
3826 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3827 gfc_array_index_type
,
3828 gfc_index_one_node
, loop
.from
[i
]);
3829 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3830 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3831 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3832 gfc_array_index_type
, size
, tmp
);
3834 gfc_add_block_to_block (pblock
, &loop
.pre
);
3835 size
= gfc_evaluate_now (size
, pblock
);
3836 gfc_add_block_to_block (pblock
, &loop
.post
);
3838 /* TODO: write a function that cleans up a loopinfo without freeing
3839 the SS chains. Currently a NOP. */
3846 /* Calculate the overall iterator number of the nested forall construct.
3847 This routine actually calculates the number of times the body of the
3848 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3849 that by the expression INNER_SIZE. The BLOCK argument specifies the
3850 block in which to calculate the result, and the optional INNER_SIZE_BODY
3851 argument contains any statements that need to executed (inside the loop)
3852 to initialize or calculate INNER_SIZE. */
3855 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3856 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3858 forall_info
*forall_tmp
= nested_forall_info
;
3862 /* We can eliminate the innermost unconditional loops with constant
3864 if (INTEGER_CST_P (inner_size
))
3867 && !forall_tmp
->mask
3868 && INTEGER_CST_P (forall_tmp
->size
))
3870 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3871 gfc_array_index_type
,
3872 inner_size
, forall_tmp
->size
);
3873 forall_tmp
= forall_tmp
->prev_nest
;
3876 /* If there are no loops left, we have our constant result. */
3881 /* Otherwise, create a temporary variable to compute the result. */
3882 number
= gfc_create_var (gfc_array_index_type
, "num");
3883 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3885 gfc_start_block (&body
);
3886 if (inner_size_body
)
3887 gfc_add_block_to_block (&body
, inner_size_body
);
3889 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3890 gfc_array_index_type
, number
, inner_size
);
3893 gfc_add_modify (&body
, number
, tmp
);
3894 tmp
= gfc_finish_block (&body
);
3896 /* Generate loops. */
3897 if (forall_tmp
!= NULL
)
3898 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3900 gfc_add_expr_to_block (block
, tmp
);
3906 /* Allocate temporary for forall construct. SIZE is the size of temporary
3907 needed. PTEMP1 is returned for space free. */
3910 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3917 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3918 if (!integer_onep (unit
))
3919 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3920 gfc_array_index_type
, size
, unit
);
3925 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3928 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3933 /* Allocate temporary for forall construct according to the information in
3934 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3935 assignment inside forall. PTEMP1 is returned for space free. */
3938 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3939 tree inner_size
, stmtblock_t
* inner_size_body
,
3940 stmtblock_t
* block
, tree
* ptemp1
)
3944 /* Calculate the total size of temporary needed in forall construct. */
3945 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3946 inner_size_body
, block
);
3948 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3952 /* Handle assignments inside forall which need temporary.
3954 forall (i=start:end:stride; maskexpr)
3957 (where e,f<i> are arbitrary expressions possibly involving i
3958 and there is a dependency between e<i> and f<i>)
3960 masktmp(:) = maskexpr(:)
3965 for (i = start; i <= end; i += stride)
3969 for (i = start; i <= end; i += stride)
3971 if (masktmp[maskindex++])
3972 tmp[count1++] = f<i>
3976 for (i = start; i <= end; i += stride)
3978 if (masktmp[maskindex++])
3979 e<i> = tmp[count1++]
3984 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3985 tree wheremask
, bool invert
,
3986 forall_info
* nested_forall_info
,
3987 stmtblock_t
* block
)
3995 stmtblock_t inner_size_body
;
3997 /* Create vars. count1 is the current iterator number of the nested
3999 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4001 /* Count is the wheremask index. */
4004 count
= gfc_create_var (gfc_array_index_type
, "count");
4005 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4010 /* Initialize count1. */
4011 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4013 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4014 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4015 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4016 if (expr1
->ts
.type
== BT_CHARACTER
)
4019 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
4022 gfc_init_se (&ssse
, NULL
);
4023 gfc_conv_expr (&ssse
, expr1
);
4024 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4025 ssse
.string_length
);
4029 if (!expr1
->ts
.u
.cl
->backend_decl
)
4032 gcc_assert (expr1
->ts
.u
.cl
->length
);
4033 gfc_init_se (&tse
, NULL
);
4034 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4035 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4037 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4038 expr1
->ts
.u
.cl
->backend_decl
);
4042 type
= gfc_typenode_for_spec (&expr1
->ts
);
4044 gfc_init_block (&inner_size_body
);
4045 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4048 /* Allocate temporary for nested forall construct according to the
4049 information in nested_forall_info and inner_size. */
4050 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4051 &inner_size_body
, block
, &ptemp1
);
4053 /* Generate codes to copy rhs to the temporary . */
4054 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4057 /* Generate body and loops according to the information in
4058 nested_forall_info. */
4059 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4060 gfc_add_expr_to_block (block
, tmp
);
4063 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4067 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4069 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4070 rss; there must be a better way. */
4071 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4074 /* Generate codes to copy the temporary to lhs. */
4075 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4079 /* Generate body and loops according to the information in
4080 nested_forall_info. */
4081 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4082 gfc_add_expr_to_block (block
, tmp
);
4086 /* Free the temporary. */
4087 tmp
= gfc_call_free (ptemp1
);
4088 gfc_add_expr_to_block (block
, tmp
);
4093 /* Translate pointer assignment inside FORALL which need temporary. */
4096 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4097 forall_info
* nested_forall_info
,
4098 stmtblock_t
* block
)
4105 gfc_array_info
*info
;
4112 tree tmp
, tmp1
, ptemp1
;
4114 count
= gfc_create_var (gfc_array_index_type
, "count");
4115 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4117 inner_size
= gfc_index_one_node
;
4118 lss
= gfc_walk_expr (expr1
);
4119 rss
= gfc_walk_expr (expr2
);
4120 if (lss
== gfc_ss_terminator
)
4122 type
= gfc_typenode_for_spec (&expr1
->ts
);
4123 type
= build_pointer_type (type
);
4125 /* Allocate temporary for nested forall construct according to the
4126 information in nested_forall_info and inner_size. */
4127 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4128 inner_size
, NULL
, block
, &ptemp1
);
4129 gfc_start_block (&body
);
4130 gfc_init_se (&lse
, NULL
);
4131 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4132 gfc_init_se (&rse
, NULL
);
4133 rse
.want_pointer
= 1;
4134 gfc_conv_expr (&rse
, expr2
);
4135 gfc_add_block_to_block (&body
, &rse
.pre
);
4136 gfc_add_modify (&body
, lse
.expr
,
4137 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4138 gfc_add_block_to_block (&body
, &rse
.post
);
4140 /* Increment count. */
4141 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4142 count
, gfc_index_one_node
);
4143 gfc_add_modify (&body
, count
, tmp
);
4145 tmp
= gfc_finish_block (&body
);
4147 /* Generate body and loops according to the information in
4148 nested_forall_info. */
4149 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4150 gfc_add_expr_to_block (block
, tmp
);
4153 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4155 gfc_start_block (&body
);
4156 gfc_init_se (&lse
, NULL
);
4157 gfc_init_se (&rse
, NULL
);
4158 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4159 lse
.want_pointer
= 1;
4160 gfc_conv_expr (&lse
, expr1
);
4161 gfc_add_block_to_block (&body
, &lse
.pre
);
4162 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4163 gfc_add_block_to_block (&body
, &lse
.post
);
4164 /* Increment count. */
4165 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4166 count
, gfc_index_one_node
);
4167 gfc_add_modify (&body
, count
, tmp
);
4168 tmp
= gfc_finish_block (&body
);
4170 /* Generate body and loops according to the information in
4171 nested_forall_info. */
4172 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4173 gfc_add_expr_to_block (block
, tmp
);
4177 gfc_init_loopinfo (&loop
);
4179 /* Associate the SS with the loop. */
4180 gfc_add_ss_to_loop (&loop
, rss
);
4182 /* Setup the scalarizing loops and bounds. */
4183 gfc_conv_ss_startstride (&loop
);
4185 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4187 info
= &rss
->info
->data
.array
;
4188 desc
= info
->descriptor
;
4190 /* Make a new descriptor. */
4191 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4192 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4193 loop
.from
, loop
.to
, 1,
4194 GFC_ARRAY_UNKNOWN
, true);
4196 /* Allocate temporary for nested forall construct. */
4197 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4198 inner_size
, NULL
, block
, &ptemp1
);
4199 gfc_start_block (&body
);
4200 gfc_init_se (&lse
, NULL
);
4201 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4202 lse
.direct_byref
= 1;
4203 gfc_conv_expr_descriptor (&lse
, expr2
);
4205 gfc_add_block_to_block (&body
, &lse
.pre
);
4206 gfc_add_block_to_block (&body
, &lse
.post
);
4208 /* Increment count. */
4209 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4210 count
, gfc_index_one_node
);
4211 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
);
4221 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4223 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4224 gfc_init_se (&lse
, NULL
);
4225 gfc_conv_expr_descriptor (&lse
, expr1
);
4226 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4227 gfc_start_block (&body
);
4228 gfc_add_block_to_block (&body
, &lse
.pre
);
4229 gfc_add_block_to_block (&body
, &lse
.post
);
4231 /* Increment count. */
4232 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4233 count
, gfc_index_one_node
);
4234 gfc_add_modify (&body
, count
, tmp
);
4236 tmp
= gfc_finish_block (&body
);
4238 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4239 gfc_add_expr_to_block (block
, tmp
);
4241 /* Free the temporary. */
4244 tmp
= gfc_call_free (ptemp1
);
4245 gfc_add_expr_to_block (block
, tmp
);
4250 /* FORALL and WHERE statements are really nasty, especially when you nest
4251 them. All the rhs of a forall assignment must be evaluated before the
4252 actual assignments are performed. Presumably this also applies to all the
4253 assignments in an inner where statement. */
4255 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4256 linear array, relying on the fact that we process in the same order in all
4259 forall (i=start:end:stride; maskexpr)
4263 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4265 count = ((end + 1 - start) / stride)
4266 masktmp(:) = maskexpr(:)
4269 for (i = start; i <= end; i += stride)
4271 if (masktmp[maskindex++])
4275 for (i = start; i <= end; i += stride)
4277 if (masktmp[maskindex++])
4281 Note that this code only works when there are no dependencies.
4282 Forall loop with array assignments and data dependencies are a real pain,
4283 because the size of the temporary cannot always be determined before the
4284 loop is executed. This problem is compounded by the presence of nested
4289 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4306 tree cycle_label
= NULL_TREE
;
4310 gfc_forall_iterator
*fa
;
4313 gfc_saved_var
*saved_vars
;
4314 iter_info
*this_forall
;
4318 /* Do nothing if the mask is false. */
4320 && code
->expr1
->expr_type
== EXPR_CONSTANT
4321 && !code
->expr1
->value
.logical
)
4322 return build_empty_stmt (input_location
);
4325 /* Count the FORALL index number. */
4326 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4330 /* Allocate the space for var, start, end, step, varexpr. */
4331 var
= XCNEWVEC (tree
, nvar
);
4332 start
= XCNEWVEC (tree
, nvar
);
4333 end
= XCNEWVEC (tree
, nvar
);
4334 step
= XCNEWVEC (tree
, nvar
);
4335 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4336 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4338 /* Allocate the space for info. */
4339 info
= XCNEW (forall_info
);
4341 gfc_start_block (&pre
);
4342 gfc_init_block (&post
);
4343 gfc_init_block (&block
);
4346 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4348 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4350 /* Allocate space for this_forall. */
4351 this_forall
= XCNEW (iter_info
);
4353 /* Create a temporary variable for the FORALL index. */
4354 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4355 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4356 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4358 /* Record it in this_forall. */
4359 this_forall
->var
= var
[n
];
4361 /* Replace the index symbol's backend_decl with the temporary decl. */
4362 sym
->backend_decl
= var
[n
];
4364 /* Work out the start, end and stride for the loop. */
4365 gfc_init_se (&se
, NULL
);
4366 gfc_conv_expr_val (&se
, fa
->start
);
4367 /* Record it in this_forall. */
4368 this_forall
->start
= se
.expr
;
4369 gfc_add_block_to_block (&block
, &se
.pre
);
4372 gfc_init_se (&se
, NULL
);
4373 gfc_conv_expr_val (&se
, fa
->end
);
4374 /* Record it in this_forall. */
4375 this_forall
->end
= se
.expr
;
4376 gfc_make_safe_expr (&se
);
4377 gfc_add_block_to_block (&block
, &se
.pre
);
4380 gfc_init_se (&se
, NULL
);
4381 gfc_conv_expr_val (&se
, fa
->stride
);
4382 /* Record it in this_forall. */
4383 this_forall
->step
= se
.expr
;
4384 gfc_make_safe_expr (&se
);
4385 gfc_add_block_to_block (&block
, &se
.pre
);
4388 /* Set the NEXT field of this_forall to NULL. */
4389 this_forall
->next
= NULL
;
4390 /* Link this_forall to the info construct. */
4391 if (info
->this_loop
)
4393 iter_info
*iter_tmp
= info
->this_loop
;
4394 while (iter_tmp
->next
!= NULL
)
4395 iter_tmp
= iter_tmp
->next
;
4396 iter_tmp
->next
= this_forall
;
4399 info
->this_loop
= this_forall
;
4405 /* Calculate the size needed for the current forall level. */
4406 size
= gfc_index_one_node
;
4407 for (n
= 0; n
< nvar
; n
++)
4409 /* size = (end + step - start) / step. */
4410 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4412 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4414 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4416 tmp
= convert (gfc_array_index_type
, tmp
);
4418 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4422 /* Record the nvar and size of current forall level. */
4428 /* If the mask is .true., consider the FORALL unconditional. */
4429 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4430 && code
->expr1
->value
.logical
)
4438 /* First we need to allocate the mask. */
4441 /* As the mask array can be very big, prefer compact boolean types. */
4442 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4443 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4444 size
, NULL
, &block
, &pmask
);
4445 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4447 /* Record them in the info structure. */
4448 info
->maskindex
= maskindex
;
4453 /* No mask was specified. */
4454 maskindex
= NULL_TREE
;
4455 mask
= pmask
= NULL_TREE
;
4458 /* Link the current forall level to nested_forall_info. */
4459 info
->prev_nest
= nested_forall_info
;
4460 nested_forall_info
= info
;
4462 /* Copy the mask into a temporary variable if required.
4463 For now we assume a mask temporary is needed. */
4466 /* As the mask array can be very big, prefer compact boolean types. */
4467 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4469 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4471 /* Start of mask assignment loop body. */
4472 gfc_start_block (&body
);
4474 /* Evaluate the mask expression. */
4475 gfc_init_se (&se
, NULL
);
4476 gfc_conv_expr_val (&se
, code
->expr1
);
4477 gfc_add_block_to_block (&body
, &se
.pre
);
4479 /* Store the mask. */
4480 se
.expr
= convert (mask_type
, se
.expr
);
4482 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4483 gfc_add_modify (&body
, tmp
, se
.expr
);
4485 /* Advance to the next mask element. */
4486 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4487 maskindex
, gfc_index_one_node
);
4488 gfc_add_modify (&body
, maskindex
, tmp
);
4490 /* Generate the loops. */
4491 tmp
= gfc_finish_block (&body
);
4492 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4493 gfc_add_expr_to_block (&block
, tmp
);
4496 if (code
->op
== EXEC_DO_CONCURRENT
)
4498 gfc_init_block (&body
);
4499 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4500 code
->cycle_label
= cycle_label
;
4501 tmp
= gfc_trans_code (code
->block
->next
);
4502 gfc_add_expr_to_block (&body
, tmp
);
4504 if (TREE_USED (cycle_label
))
4506 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4507 gfc_add_expr_to_block (&body
, tmp
);
4510 tmp
= gfc_finish_block (&body
);
4511 nested_forall_info
->do_concurrent
= true;
4512 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4513 gfc_add_expr_to_block (&block
, tmp
);
4517 c
= code
->block
->next
;
4519 /* TODO: loop merging in FORALL statements. */
4520 /* Now that we've got a copy of the mask, generate the assignment loops. */
4526 /* A scalar or array assignment. DO the simple check for
4527 lhs to rhs dependencies. These make a temporary for the
4528 rhs and form a second forall block to copy to variable. */
4529 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4531 /* Temporaries due to array assignment data dependencies introduce
4532 no end of problems. */
4533 if (need_temp
|| flag_test_forall_temp
)
4534 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4535 nested_forall_info
, &block
);
4538 /* Use the normal assignment copying routines. */
4539 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4541 /* Generate body and loops. */
4542 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4544 gfc_add_expr_to_block (&block
, tmp
);
4547 /* Cleanup any temporary symtrees that have been made to deal
4548 with dependencies. */
4550 cleanup_forall_symtrees (c
);
4555 /* Translate WHERE or WHERE construct nested in FORALL. */
4556 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4559 /* Pointer assignment inside FORALL. */
4560 case EXEC_POINTER_ASSIGN
:
4561 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4562 /* Avoid cases where a temporary would never be needed and where
4563 the temp code is guaranteed to fail. */
4565 || (flag_test_forall_temp
4566 && c
->expr2
->expr_type
!= EXPR_CONSTANT
4567 && c
->expr2
->expr_type
!= EXPR_NULL
))
4568 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4569 nested_forall_info
, &block
);
4572 /* Use the normal assignment copying routines. */
4573 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4575 /* Generate body and loops. */
4576 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4578 gfc_add_expr_to_block (&block
, tmp
);
4583 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4584 gfc_add_expr_to_block (&block
, tmp
);
4587 /* Explicit subroutine calls are prevented by the frontend but interface
4588 assignments can legitimately produce them. */
4589 case EXEC_ASSIGN_CALL
:
4590 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4591 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4592 gfc_add_expr_to_block (&block
, tmp
);
4603 /* Restore the original index variables. */
4604 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4605 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4607 /* Free the space for var, start, end, step, varexpr. */
4615 for (this_forall
= info
->this_loop
; this_forall
;)
4617 iter_info
*next
= this_forall
->next
;
4622 /* Free the space for this forall_info. */
4627 /* Free the temporary for the mask. */
4628 tmp
= gfc_call_free (pmask
);
4629 gfc_add_expr_to_block (&block
, tmp
);
4632 pushdecl (maskindex
);
4634 gfc_add_block_to_block (&pre
, &block
);
4635 gfc_add_block_to_block (&pre
, &post
);
4637 return gfc_finish_block (&pre
);
4641 /* Translate the FORALL statement or construct. */
4643 tree
gfc_trans_forall (gfc_code
* code
)
4645 return gfc_trans_forall_1 (code
, NULL
);
4649 /* Translate the DO CONCURRENT construct. */
4651 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4653 return gfc_trans_forall_1 (code
, NULL
);
4657 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4658 If the WHERE construct is nested in FORALL, compute the overall temporary
4659 needed by the WHERE mask expression multiplied by the iterator number of
4661 ME is the WHERE mask expression.
4662 MASK is the current execution mask upon input, whose sense may or may
4663 not be inverted as specified by the INVERT argument.
4664 CMASK is the updated execution mask on output, or NULL if not required.
4665 PMASK is the pending execution mask on output, or NULL if not required.
4666 BLOCK is the block in which to place the condition evaluation loops. */
4669 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4670 tree mask
, bool invert
, tree cmask
, tree pmask
,
4671 tree mask_type
, stmtblock_t
* block
)
4676 stmtblock_t body
, body1
;
4677 tree count
, cond
, mtmp
;
4680 gfc_init_loopinfo (&loop
);
4682 lss
= gfc_walk_expr (me
);
4683 rss
= gfc_walk_expr (me
);
4685 /* Variable to index the temporary. */
4686 count
= gfc_create_var (gfc_array_index_type
, "count");
4687 /* Initialize count. */
4688 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4690 gfc_start_block (&body
);
4692 gfc_init_se (&rse
, NULL
);
4693 gfc_init_se (&lse
, NULL
);
4695 if (lss
== gfc_ss_terminator
)
4697 gfc_init_block (&body1
);
4701 /* Initialize the loop. */
4702 gfc_init_loopinfo (&loop
);
4704 /* We may need LSS to determine the shape of the expression. */
4705 gfc_add_ss_to_loop (&loop
, lss
);
4706 gfc_add_ss_to_loop (&loop
, rss
);
4708 gfc_conv_ss_startstride (&loop
);
4709 gfc_conv_loop_setup (&loop
, &me
->where
);
4711 gfc_mark_ss_chain_used (rss
, 1);
4712 /* Start the loop body. */
4713 gfc_start_scalarized_body (&loop
, &body1
);
4715 /* Translate the expression. */
4716 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4718 gfc_conv_expr (&rse
, me
);
4721 /* Variable to evaluate mask condition. */
4722 cond
= gfc_create_var (mask_type
, "cond");
4723 if (mask
&& (cmask
|| pmask
))
4724 mtmp
= gfc_create_var (mask_type
, "mask");
4725 else mtmp
= NULL_TREE
;
4727 gfc_add_block_to_block (&body1
, &lse
.pre
);
4728 gfc_add_block_to_block (&body1
, &rse
.pre
);
4730 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4732 if (mask
&& (cmask
|| pmask
))
4734 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4736 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4737 gfc_add_modify (&body1
, mtmp
, tmp
);
4742 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4745 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4747 gfc_add_modify (&body1
, tmp1
, tmp
);
4752 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4753 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4755 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4757 gfc_add_modify (&body1
, tmp1
, tmp
);
4760 gfc_add_block_to_block (&body1
, &lse
.post
);
4761 gfc_add_block_to_block (&body1
, &rse
.post
);
4763 if (lss
== gfc_ss_terminator
)
4765 gfc_add_block_to_block (&body
, &body1
);
4769 /* Increment count. */
4770 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4771 count
, gfc_index_one_node
);
4772 gfc_add_modify (&body1
, count
, tmp1
);
4774 /* Generate the copying loops. */
4775 gfc_trans_scalarizing_loops (&loop
, &body1
);
4777 gfc_add_block_to_block (&body
, &loop
.pre
);
4778 gfc_add_block_to_block (&body
, &loop
.post
);
4780 gfc_cleanup_loop (&loop
);
4781 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4782 as tree nodes in SS may not be valid in different scope. */
4785 tmp1
= gfc_finish_block (&body
);
4786 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4787 if (nested_forall_info
!= NULL
)
4788 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4790 gfc_add_expr_to_block (block
, tmp1
);
4794 /* Translate an assignment statement in a WHERE statement or construct
4795 statement. The MASK expression is used to control which elements
4796 of EXPR1 shall be assigned. The sense of MASK is specified by
4800 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4801 tree mask
, bool invert
,
4802 tree count1
, tree count2
,
4808 gfc_ss
*lss_section
;
4815 tree index
, maskexpr
;
4817 /* A defined assignment. */
4818 if (cnext
&& cnext
->resolved_sym
)
4819 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4822 /* TODO: handle this special case.
4823 Special case a single function returning an array. */
4824 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4826 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4832 /* Assignment of the form lhs = rhs. */
4833 gfc_start_block (&block
);
4835 gfc_init_se (&lse
, NULL
);
4836 gfc_init_se (&rse
, NULL
);
4839 lss
= gfc_walk_expr (expr1
);
4842 /* In each where-assign-stmt, the mask-expr and the variable being
4843 defined shall be arrays of the same shape. */
4844 gcc_assert (lss
!= gfc_ss_terminator
);
4846 /* The assignment needs scalarization. */
4849 /* Find a non-scalar SS from the lhs. */
4850 while (lss_section
!= gfc_ss_terminator
4851 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4852 lss_section
= lss_section
->next
;
4854 gcc_assert (lss_section
!= gfc_ss_terminator
);
4856 /* Initialize the scalarizer. */
4857 gfc_init_loopinfo (&loop
);
4860 rss
= gfc_walk_expr (expr2
);
4861 if (rss
== gfc_ss_terminator
)
4863 /* The rhs is scalar. Add a ss for the expression. */
4864 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4865 rss
->info
->where
= 1;
4868 /* Associate the SS with the loop. */
4869 gfc_add_ss_to_loop (&loop
, lss
);
4870 gfc_add_ss_to_loop (&loop
, rss
);
4872 /* Calculate the bounds of the scalarization. */
4873 gfc_conv_ss_startstride (&loop
);
4875 /* Resolve any data dependencies in the statement. */
4876 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4878 /* Setup the scalarizing loops. */
4879 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4881 /* Setup the gfc_se structures. */
4882 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4883 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4886 gfc_mark_ss_chain_used (rss
, 1);
4887 if (loop
.temp_ss
== NULL
)
4890 gfc_mark_ss_chain_used (lss
, 1);
4894 lse
.ss
= loop
.temp_ss
;
4895 gfc_mark_ss_chain_used (lss
, 3);
4896 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4899 /* Start the scalarized loop body. */
4900 gfc_start_scalarized_body (&loop
, &body
);
4902 /* Translate the expression. */
4903 gfc_conv_expr (&rse
, expr2
);
4904 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4905 gfc_conv_tmp_array_ref (&lse
);
4907 gfc_conv_expr (&lse
, expr1
);
4909 /* Form the mask expression according to the mask. */
4911 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4913 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4914 TREE_TYPE (maskexpr
), maskexpr
);
4916 /* Use the scalar assignment as is. */
4917 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4918 false, loop
.temp_ss
== NULL
);
4920 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4922 gfc_add_expr_to_block (&body
, tmp
);
4924 if (lss
== gfc_ss_terminator
)
4926 /* Increment count1. */
4927 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4928 count1
, gfc_index_one_node
);
4929 gfc_add_modify (&body
, count1
, tmp
);
4931 /* Use the scalar assignment as is. */
4932 gfc_add_block_to_block (&block
, &body
);
4936 gcc_assert (lse
.ss
== gfc_ss_terminator
4937 && rse
.ss
== gfc_ss_terminator
);
4939 if (loop
.temp_ss
!= NULL
)
4941 /* Increment count1 before finish the main body of a scalarized
4943 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4944 gfc_array_index_type
, count1
, gfc_index_one_node
);
4945 gfc_add_modify (&body
, count1
, tmp
);
4946 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4948 /* We need to copy the temporary to the actual lhs. */
4949 gfc_init_se (&lse
, NULL
);
4950 gfc_init_se (&rse
, NULL
);
4951 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4952 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4954 rse
.ss
= loop
.temp_ss
;
4957 gfc_conv_tmp_array_ref (&rse
);
4958 gfc_conv_expr (&lse
, expr1
);
4960 gcc_assert (lse
.ss
== gfc_ss_terminator
4961 && rse
.ss
== gfc_ss_terminator
);
4963 /* Form the mask expression according to the mask tree list. */
4965 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4967 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4968 TREE_TYPE (maskexpr
), maskexpr
);
4970 /* Use the scalar assignment as is. */
4971 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
4972 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
4973 build_empty_stmt (input_location
));
4974 gfc_add_expr_to_block (&body
, tmp
);
4976 /* Increment count2. */
4977 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4978 gfc_array_index_type
, count2
,
4979 gfc_index_one_node
);
4980 gfc_add_modify (&body
, count2
, tmp
);
4984 /* Increment count1. */
4985 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4986 gfc_array_index_type
, count1
,
4987 gfc_index_one_node
);
4988 gfc_add_modify (&body
, count1
, tmp
);
4991 /* Generate the copying loops. */
4992 gfc_trans_scalarizing_loops (&loop
, &body
);
4994 /* Wrap the whole thing up. */
4995 gfc_add_block_to_block (&block
, &loop
.pre
);
4996 gfc_add_block_to_block (&block
, &loop
.post
);
4997 gfc_cleanup_loop (&loop
);
5000 return gfc_finish_block (&block
);
5004 /* Translate the WHERE construct or statement.
5005 This function can be called iteratively to translate the nested WHERE
5006 construct or statement.
5007 MASK is the control mask. */
5010 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
5011 forall_info
* nested_forall_info
, stmtblock_t
* block
)
5013 stmtblock_t inner_size_body
;
5014 tree inner_size
, size
;
5023 tree count1
, count2
;
5027 tree pcmask
= NULL_TREE
;
5028 tree ppmask
= NULL_TREE
;
5029 tree cmask
= NULL_TREE
;
5030 tree pmask
= NULL_TREE
;
5031 gfc_actual_arglist
*arg
;
5033 /* the WHERE statement or the WHERE construct statement. */
5034 cblock
= code
->block
;
5036 /* As the mask array can be very big, prefer compact boolean types. */
5037 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5039 /* Determine which temporary masks are needed. */
5042 /* One clause: No ELSEWHEREs. */
5043 need_cmask
= (cblock
->next
!= 0);
5046 else if (cblock
->block
->block
)
5048 /* Three or more clauses: Conditional ELSEWHEREs. */
5052 else if (cblock
->next
)
5054 /* Two clauses, the first non-empty. */
5056 need_pmask
= (mask
!= NULL_TREE
5057 && cblock
->block
->next
!= 0);
5059 else if (!cblock
->block
->next
)
5061 /* Two clauses, both empty. */
5065 /* Two clauses, the first empty, the second non-empty. */
5068 need_cmask
= (cblock
->block
->expr1
!= 0);
5077 if (need_cmask
|| need_pmask
)
5079 /* Calculate the size of temporary needed by the mask-expr. */
5080 gfc_init_block (&inner_size_body
);
5081 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5082 &inner_size_body
, &lss
, &rss
);
5084 gfc_free_ss_chain (lss
);
5085 gfc_free_ss_chain (rss
);
5087 /* Calculate the total size of temporary needed. */
5088 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5089 &inner_size_body
, block
);
5091 /* Check whether the size is negative. */
5092 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
5093 gfc_index_zero_node
);
5094 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5095 cond
, gfc_index_zero_node
, size
);
5096 size
= gfc_evaluate_now (size
, block
);
5098 /* Allocate temporary for WHERE mask if needed. */
5100 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5103 /* Allocate temporary for !mask if needed. */
5105 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5111 /* Each time around this loop, the where clause is conditional
5112 on the value of mask and invert, which are updated at the
5113 bottom of the loop. */
5115 /* Has mask-expr. */
5118 /* Ensure that the WHERE mask will be evaluated exactly once.
5119 If there are no statements in this WHERE/ELSEWHERE clause,
5120 then we don't need to update the control mask (cmask).
5121 If this is the last clause of the WHERE construct, then
5122 we don't need to update the pending control mask (pmask). */
5124 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5126 cblock
->next
? cmask
: NULL_TREE
,
5127 cblock
->block
? pmask
: NULL_TREE
,
5130 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5132 (cblock
->next
|| cblock
->block
)
5133 ? cmask
: NULL_TREE
,
5134 NULL_TREE
, mask_type
, block
);
5138 /* It's a final elsewhere-stmt. No mask-expr is present. */
5142 /* The body of this where clause are controlled by cmask with
5143 sense specified by invert. */
5145 /* Get the assignment statement of a WHERE statement, or the first
5146 statement in where-body-construct of a WHERE construct. */
5147 cnext
= cblock
->next
;
5152 /* WHERE assignment statement. */
5153 case EXEC_ASSIGN_CALL
:
5155 arg
= cnext
->ext
.actual
;
5156 expr1
= expr2
= NULL
;
5157 for (; arg
; arg
= arg
->next
)
5169 expr1
= cnext
->expr1
;
5170 expr2
= cnext
->expr2
;
5172 if (nested_forall_info
!= NULL
)
5174 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5175 if ((need_temp
|| flag_test_forall_temp
)
5176 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5177 gfc_trans_assign_need_temp (expr1
, expr2
,
5179 nested_forall_info
, block
);
5182 /* Variables to control maskexpr. */
5183 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5184 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5185 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5186 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5188 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5193 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5195 gfc_add_expr_to_block (block
, tmp
);
5200 /* Variables to control maskexpr. */
5201 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5202 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5203 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5204 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5206 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5210 gfc_add_expr_to_block (block
, tmp
);
5215 /* WHERE or WHERE construct is part of a where-body-construct. */
5217 gfc_trans_where_2 (cnext
, cmask
, invert
,
5218 nested_forall_info
, block
);
5225 /* The next statement within the same where-body-construct. */
5226 cnext
= cnext
->next
;
5228 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5229 cblock
= cblock
->block
;
5230 if (mask
== NULL_TREE
)
5232 /* If we're the initial WHERE, we can simply invert the sense
5233 of the current mask to obtain the "mask" for the remaining
5240 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5246 /* If we allocated a pending mask array, deallocate it now. */
5249 tmp
= gfc_call_free (ppmask
);
5250 gfc_add_expr_to_block (block
, tmp
);
5253 /* If we allocated a current mask array, deallocate it now. */
5256 tmp
= gfc_call_free (pcmask
);
5257 gfc_add_expr_to_block (block
, tmp
);
5261 /* Translate a simple WHERE construct or statement without dependencies.
5262 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5263 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5264 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5267 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5269 stmtblock_t block
, body
;
5270 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5271 tree tmp
, cexpr
, tstmt
, estmt
;
5272 gfc_ss
*css
, *tdss
, *tsss
;
5273 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5277 bool maybe_workshare
= false;
5279 /* Allow the scalarizer to workshare simple where loops. */
5280 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5281 == OMPWS_WORKSHARE_FLAG
)
5283 maybe_workshare
= true;
5284 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5287 cond
= cblock
->expr1
;
5288 tdst
= cblock
->next
->expr1
;
5289 tsrc
= cblock
->next
->expr2
;
5290 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5291 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5293 gfc_start_block (&block
);
5294 gfc_init_loopinfo (&loop
);
5296 /* Handle the condition. */
5297 gfc_init_se (&cse
, NULL
);
5298 css
= gfc_walk_expr (cond
);
5299 gfc_add_ss_to_loop (&loop
, css
);
5301 /* Handle the then-clause. */
5302 gfc_init_se (&tdse
, NULL
);
5303 gfc_init_se (&tsse
, NULL
);
5304 tdss
= gfc_walk_expr (tdst
);
5305 tsss
= gfc_walk_expr (tsrc
);
5306 if (tsss
== gfc_ss_terminator
)
5308 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5309 tsss
->info
->where
= 1;
5311 gfc_add_ss_to_loop (&loop
, tdss
);
5312 gfc_add_ss_to_loop (&loop
, tsss
);
5316 /* Handle the else clause. */
5317 gfc_init_se (&edse
, NULL
);
5318 gfc_init_se (&esse
, NULL
);
5319 edss
= gfc_walk_expr (edst
);
5320 esss
= gfc_walk_expr (esrc
);
5321 if (esss
== gfc_ss_terminator
)
5323 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5324 esss
->info
->where
= 1;
5326 gfc_add_ss_to_loop (&loop
, edss
);
5327 gfc_add_ss_to_loop (&loop
, esss
);
5330 gfc_conv_ss_startstride (&loop
);
5331 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5333 gfc_mark_ss_chain_used (css
, 1);
5334 gfc_mark_ss_chain_used (tdss
, 1);
5335 gfc_mark_ss_chain_used (tsss
, 1);
5338 gfc_mark_ss_chain_used (edss
, 1);
5339 gfc_mark_ss_chain_used (esss
, 1);
5342 gfc_start_scalarized_body (&loop
, &body
);
5344 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5345 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5346 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5352 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5353 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5358 gfc_conv_expr (&cse
, cond
);
5359 gfc_add_block_to_block (&body
, &cse
.pre
);
5362 gfc_conv_expr (&tsse
, tsrc
);
5363 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5364 gfc_conv_tmp_array_ref (&tdse
);
5366 gfc_conv_expr (&tdse
, tdst
);
5370 gfc_conv_expr (&esse
, esrc
);
5371 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5372 gfc_conv_tmp_array_ref (&edse
);
5374 gfc_conv_expr (&edse
, edst
);
5377 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5378 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5380 : build_empty_stmt (input_location
);
5381 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5382 gfc_add_expr_to_block (&body
, tmp
);
5383 gfc_add_block_to_block (&body
, &cse
.post
);
5385 if (maybe_workshare
)
5386 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5387 gfc_trans_scalarizing_loops (&loop
, &body
);
5388 gfc_add_block_to_block (&block
, &loop
.pre
);
5389 gfc_add_block_to_block (&block
, &loop
.post
);
5390 gfc_cleanup_loop (&loop
);
5392 return gfc_finish_block (&block
);
5395 /* As the WHERE or WHERE construct statement can be nested, we call
5396 gfc_trans_where_2 to do the translation, and pass the initial
5397 NULL values for both the control mask and the pending control mask. */
5400 gfc_trans_where (gfc_code
* code
)
5406 cblock
= code
->block
;
5408 && cblock
->next
->op
== EXEC_ASSIGN
5409 && !cblock
->next
->next
)
5411 eblock
= cblock
->block
;
5414 /* A simple "WHERE (cond) x = y" statement or block is
5415 dependence free if cond is not dependent upon writing x,
5416 and the source y is unaffected by the destination x. */
5417 if (!gfc_check_dependency (cblock
->next
->expr1
,
5419 && !gfc_check_dependency (cblock
->next
->expr1
,
5420 cblock
->next
->expr2
, 0))
5421 return gfc_trans_where_3 (cblock
, NULL
);
5423 else if (!eblock
->expr1
5426 && eblock
->next
->op
== EXEC_ASSIGN
5427 && !eblock
->next
->next
)
5429 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5430 block is dependence free if cond is not dependent on writes
5431 to x1 and x2, y1 is not dependent on writes to x2, and y2
5432 is not dependent on writes to x1, and both y's are not
5433 dependent upon their own x's. In addition to this, the
5434 final two dependency checks below exclude all but the same
5435 array reference if the where and elswhere destinations
5436 are the same. In short, this is VERY conservative and this
5437 is needed because the two loops, required by the standard
5438 are coalesced in gfc_trans_where_3. */
5439 if (!gfc_check_dependency (cblock
->next
->expr1
,
5441 && !gfc_check_dependency (eblock
->next
->expr1
,
5443 && !gfc_check_dependency (cblock
->next
->expr1
,
5444 eblock
->next
->expr2
, 1)
5445 && !gfc_check_dependency (eblock
->next
->expr1
,
5446 cblock
->next
->expr2
, 1)
5447 && !gfc_check_dependency (cblock
->next
->expr1
,
5448 cblock
->next
->expr2
, 1)
5449 && !gfc_check_dependency (eblock
->next
->expr1
,
5450 eblock
->next
->expr2
, 1)
5451 && !gfc_check_dependency (cblock
->next
->expr1
,
5452 eblock
->next
->expr1
, 0)
5453 && !gfc_check_dependency (eblock
->next
->expr1
,
5454 cblock
->next
->expr1
, 0))
5455 return gfc_trans_where_3 (cblock
, eblock
);
5459 gfc_start_block (&block
);
5461 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5463 return gfc_finish_block (&block
);
5467 /* CYCLE a DO loop. The label decl has already been created by
5468 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5469 node at the head of the loop. We must mark the label as used. */
5472 gfc_trans_cycle (gfc_code
* code
)
5476 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5477 gcc_assert (cycle_label
);
5479 TREE_USED (cycle_label
) = 1;
5480 return build1_v (GOTO_EXPR
, cycle_label
);
5484 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5485 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5489 gfc_trans_exit (gfc_code
* code
)
5493 exit_label
= code
->ext
.which_construct
->exit_label
;
5494 gcc_assert (exit_label
);
5496 TREE_USED (exit_label
) = 1;
5497 return build1_v (GOTO_EXPR
, exit_label
);
5501 /* Get the initializer expression for the code and expr of an allocate.
5502 When no initializer is needed return NULL. */
5505 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
5507 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
5510 /* An explicit type was given in allocate ( T:: object). */
5511 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
5512 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
5513 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
5514 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
5516 if (gfc_bt_struct (expr
->ts
.type
)
5517 && (expr
->ts
.u
.derived
->attr
.alloc_comp
5518 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
5519 return gfc_default_initializer (&expr
->ts
);
5521 if (expr
->ts
.type
== BT_CLASS
5522 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
5523 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
5524 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
5529 /* Translate the ALLOCATE statement. */
5532 gfc_trans_allocate (gfc_code
* code
)
5535 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
5545 tree al_vptr
, al_len
;
5546 /* If an expr3 is present, then store the tree for accessing its
5547 _vptr, and _len components in the variables, respectively. The
5548 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5549 the trees may be the NULL_TREE indicating that this is not
5550 available for expr3's type. */
5551 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5552 /* Classify what expr3 stores. */
5553 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5557 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
5558 bool needs_caf_sync
, caf_refs_comp
;
5559 gfc_symtree
*newsym
= NULL
;
5560 symbol_attribute caf_attr
;
5561 gfc_actual_arglist
*param_list
;
5563 if (!code
->ext
.alloc
.list
)
5566 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5567 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5568 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5570 is_coarray
= needs_caf_sync
= false;
5572 gfc_init_block (&block
);
5573 gfc_init_block (&post
);
5575 /* STAT= (and maybe ERRMSG=) is present. */
5579 tree gfc_int4_type_node
= gfc_get_int_type (4);
5580 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5582 /* ERRMSG= only makes sense with STAT=. */
5585 gfc_init_se (&se
, NULL
);
5586 se
.want_pointer
= 1;
5587 gfc_conv_expr_lhs (&se
, code
->expr2
);
5589 errlen
= se
.string_length
;
5593 errmsg
= null_pointer_node
;
5594 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5597 /* GOTO destinations. */
5598 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5599 label_finish
= gfc_build_label_decl (NULL_TREE
);
5600 TREE_USED (label_finish
) = 0;
5603 /* When an expr3 is present evaluate it only once. The standards prevent a
5604 dependency of expr3 on the objects in the allocate list. An expr3 can
5605 be pre-evaluated in all cases. One just has to make sure, to use the
5606 correct way, i.e., to get the descriptor or to get a reference
5610 bool vtab_needed
= false, temp_var_needed
= false,
5611 temp_obj_created
= false;
5613 is_coarray
= gfc_is_coarray (code
->expr3
);
5615 /* Figure whether we need the vtab from expr3. */
5616 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5618 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5620 gfc_init_se (&se
, NULL
);
5621 /* When expr3 is a variable, i.e., a very simple expression,
5622 then convert it once here. */
5623 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5624 || code
->expr3
->expr_type
== EXPR_ARRAY
5625 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5627 if (!code
->expr3
->mold
5628 || code
->expr3
->ts
.type
== BT_CHARACTER
5630 || code
->ext
.alloc
.arr_spec_from_expr3
)
5632 /* Convert expr3 to a tree. For all "simple" expression just
5633 get the descriptor or the reference, respectively, depending
5634 on the rank of the expr. */
5635 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5636 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5639 gfc_conv_expr_reference (&se
, code
->expr3
);
5641 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5642 NOP_EXPR, which prevents gfortran from getting the vptr
5643 from the source=-expression. Remove the NOP_EXPR and go
5644 with the POINTER_PLUS_EXPR in this case. */
5645 if (code
->expr3
->ts
.type
== BT_CLASS
5646 && TREE_CODE (se
.expr
) == NOP_EXPR
5647 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5648 == POINTER_PLUS_EXPR
5650 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5652 /* Create a temp variable only for component refs to prevent
5653 having to go through the full deref-chain each time and to
5654 simplfy computation of array properties. */
5655 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5660 /* In all other cases evaluate the expr3. */
5661 symbol_attribute attr
;
5662 /* Get the descriptor for all arrays, that are not allocatable or
5663 pointer, because the latter are descriptors already.
5664 The exception are function calls returning a class object:
5665 The descriptor is stored in their results _data component, which
5666 is easier to access, when first a temporary variable for the
5667 result is created and the descriptor retrieved from there. */
5668 attr
= gfc_expr_attr (code
->expr3
);
5669 if (code
->expr3
->rank
!= 0
5670 && ((!attr
.allocatable
&& !attr
.pointer
)
5671 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5672 && (code
->expr3
->ts
.type
!= BT_CLASS
5673 || (code
->expr3
->value
.function
.isym
5674 && code
->expr3
->value
.function
.isym
5675 ->transformational
)))))
5676 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5678 gfc_conv_expr_reference (&se
, code
->expr3
);
5679 if (code
->expr3
->ts
.type
== BT_CLASS
)
5680 gfc_conv_class_to_class (&se
, code
->expr3
,
5684 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
5686 gfc_add_block_to_block (&block
, &se
.pre
);
5687 gfc_add_block_to_block (&post
, &se
.post
);
5689 /* Special case when string in expr3 is zero. */
5690 if (code
->expr3
->ts
.type
== BT_CHARACTER
5691 && integer_zerop (se
.string_length
))
5693 gfc_init_se (&se
, NULL
);
5694 temp_var_needed
= false;
5695 expr3_len
= integer_zero_node
;
5698 /* Prevent aliasing, i.e., se.expr may be already a
5699 variable declaration. */
5700 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5703 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5705 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5707 /* Get the array descriptor and prepare it to be assigned to the
5708 temporary variable var. For classes the array descriptor is
5709 in the _data component and the object goes into the
5710 GFC_DECL_SAVED_DESCRIPTOR. */
5711 if (code
->expr3
->ts
.type
== BT_CLASS
5712 && code
->expr3
->rank
!= 0)
5714 /* When an array_ref was in expr3, then the descriptor is the
5716 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5718 desc
= TREE_OPERAND (tmp
, 0);
5723 tmp
= gfc_class_data_get (tmp
);
5725 if (code
->ext
.alloc
.arr_spec_from_expr3
)
5729 desc
= !is_coarray
? se
.expr
5730 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5731 /* We need a regular (non-UID) symbol here, therefore give a
5733 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5734 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5736 gfc_allocate_lang_decl (var
);
5737 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5739 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5742 if (se
.string_length
)
5743 /* Evaluate it assuming that it also is complicated like expr3. */
5744 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5749 expr3_len
= se
.string_length
;
5752 /* Deallocate any allocatable components in expressions that use a
5753 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
5754 E.g. temporaries of a function call need freeing of their components
5756 if ((code
->expr3
->ts
.type
== BT_DERIVED
5757 || code
->expr3
->ts
.type
== BT_CLASS
)
5758 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
5759 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
)
5761 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
5762 expr3
, code
->expr3
->rank
);
5763 gfc_prepend_expr_to_block (&post
, tmp
);
5766 /* Store what the expr3 is to be used for. */
5767 if (e3_is
== E3_UNSET
)
5768 e3_is
= expr3
!= NULL_TREE
?
5769 (code
->ext
.alloc
.arr_spec_from_expr3
?
5771 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
5774 /* Figure how to get the _vtab entry. This also obtains the tree
5775 expression for accessing the _len component, because only
5776 unlimited polymorphic objects, which are a subcategory of class
5777 types, have a _len component. */
5778 if (code
->expr3
->ts
.type
== BT_CLASS
)
5781 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
5782 build_fold_indirect_ref (expr3
): expr3
;
5783 /* Polymorphic SOURCE: VPTR must be determined at run time.
5784 expr3 may be a temporary array declaration, therefore check for
5785 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5786 if (tmp
!= NULL_TREE
5787 && (e3_is
== E3_DESC
5788 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
5789 && (VAR_P (tmp
) || !code
->expr3
->ref
))
5790 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
5791 tmp
= gfc_class_vptr_get (expr3
);
5794 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5795 gfc_add_vptr_component (rhs
);
5796 gfc_init_se (&se
, NULL
);
5797 se
.want_pointer
= 1;
5798 gfc_conv_expr (&se
, rhs
);
5800 gfc_free_expr (rhs
);
5802 /* Set the element size. */
5803 expr3_esize
= gfc_vptr_size_get (tmp
);
5806 /* Initialize the ref to the _len component. */
5807 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5809 /* Same like for retrieving the _vptr. */
5810 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5811 expr3_len
= gfc_class_len_get (expr3
);
5814 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5815 gfc_add_len_component (rhs
);
5816 gfc_init_se (&se
, NULL
);
5817 gfc_conv_expr (&se
, rhs
);
5818 expr3_len
= se
.expr
;
5819 gfc_free_expr (rhs
);
5825 /* When the object to allocate is polymorphic type, then it
5826 needs its vtab set correctly, so deduce the required _vtab
5827 and _len from the source expression. */
5830 /* VPTR is fixed at compile time. */
5833 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5835 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5836 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5839 /* _len component needs to be set, when ts is a character
5841 if (expr3_len
== NULL_TREE
5842 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5844 if (code
->expr3
->ts
.u
.cl
5845 && code
->expr3
->ts
.u
.cl
->length
)
5847 gfc_init_se (&se
, NULL
);
5848 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5849 gfc_add_block_to_block (&block
, &se
.pre
);
5850 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5852 gcc_assert (expr3_len
);
5854 /* For character arrays only the kind's size is needed, because
5855 the array mem_size is _len * (elem_size = kind_size).
5856 For all other get the element size in the normal way. */
5857 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5858 expr3_esize
= TYPE_SIZE_UNIT (
5859 gfc_get_char_type (code
->expr3
->ts
.kind
));
5861 expr3_esize
= TYPE_SIZE_UNIT (
5862 gfc_typenode_for_spec (&code
->expr3
->ts
));
5864 gcc_assert (expr3_esize
);
5865 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5866 if (e3_is
== E3_MOLD
)
5867 /* The expr3 is no longer valid after this point. */
5870 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5872 /* Compute the explicit typespec given only once for all objects
5874 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5875 expr3_esize
= TYPE_SIZE_UNIT (
5876 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5880 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
);
5881 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5882 gfc_init_se (&se_sz
, NULL
);
5883 gfc_conv_expr (&se_sz
, sz
);
5885 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5886 tmp
= TYPE_SIZE_UNIT (tmp
);
5887 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5888 gfc_add_block_to_block (&block
, &se_sz
.pre
);
5889 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5890 TREE_TYPE (se_sz
.expr
),
5892 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
5896 /* The routine gfc_trans_assignment () already implements all
5897 techniques needed. Unfortunately we may have a temporary
5898 variable for the source= expression here. When that is the
5899 case convert this variable into a temporary gfc_expr of type
5900 EXPR_VARIABLE and used it as rhs for the assignment. The
5901 advantage is, that we get scalarizer support for free,
5902 don't have to take care about scalar to array treatment and
5903 will benefit of every enhancements gfc_trans_assignment ()
5905 No need to check whether e3_is is E3_UNSET, because that is
5906 done by expr3 != NULL_TREE.
5907 Exclude variables since the following block does not handle
5908 array sections. In any case, there is no harm in sending
5909 variables to gfc_trans_assignment because there is no
5910 evaluation of variables. */
5913 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
5914 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
5915 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5917 /* Build a temporary symtree and symbol. Do not add it to the current
5918 namespace to prevent accidently modifying a colliding
5920 newsym
= XCNEW (gfc_symtree
);
5921 /* The name of the symtree should be unique, because gfc_create_var ()
5922 took care about generating the identifier. */
5924 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
5925 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5926 /* The backend_decl is known. It is expr3, which is inserted
5928 newsym
->n
.sym
->backend_decl
= expr3
;
5929 e3rhs
= gfc_get_expr ();
5930 e3rhs
->rank
= code
->expr3
->rank
;
5931 e3rhs
->symtree
= newsym
;
5932 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
5933 newsym
->n
.sym
->attr
.referenced
= 1;
5934 e3rhs
->expr_type
= EXPR_VARIABLE
;
5935 e3rhs
->where
= code
->expr3
->where
;
5936 /* Set the symbols type, upto it was BT_UNKNOWN. */
5937 if (IS_CLASS_ARRAY (code
->expr3
)
5938 && code
->expr3
->expr_type
== EXPR_FUNCTION
5939 && code
->expr3
->value
.function
.isym
5940 && code
->expr3
->value
.function
.isym
->transformational
)
5942 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5944 else if (code
->expr3
->ts
.type
== BT_CLASS
5945 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
5946 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5948 e3rhs
->ts
= code
->expr3
->ts
;
5949 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5950 /* Check whether the expr3 is array valued. */
5953 gfc_array_spec
*arr
;
5954 arr
= gfc_get_array_spec ();
5955 arr
->rank
= e3rhs
->rank
;
5956 arr
->type
= AS_DEFERRED
;
5957 /* Set the dimension and pointer attribute for arrays
5958 to be on the safe side. */
5959 newsym
->n
.sym
->attr
.dimension
= 1;
5960 newsym
->n
.sym
->attr
.pointer
= 1;
5961 newsym
->n
.sym
->as
= arr
;
5962 if (IS_CLASS_ARRAY (code
->expr3
)
5963 && code
->expr3
->expr_type
== EXPR_FUNCTION
5964 && code
->expr3
->value
.function
.isym
5965 && code
->expr3
->value
.function
.isym
->transformational
)
5967 gfc_array_spec
*tarr
;
5968 tarr
= gfc_get_array_spec ();
5970 e3rhs
->ts
.u
.derived
->as
= tarr
;
5972 gfc_add_full_array_ref (e3rhs
, arr
);
5974 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
5975 newsym
->n
.sym
->attr
.pointer
= 1;
5976 /* The string length is known, too. Set it for char arrays. */
5977 if (e3rhs
->ts
.type
== BT_CHARACTER
)
5978 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
5979 gfc_commit_symbol (newsym
->n
.sym
);
5982 e3rhs
= gfc_copy_expr (code
->expr3
);
5985 /* Loop over all objects to allocate. */
5986 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5988 expr
= gfc_copy_expr (al
->expr
);
5989 /* UNLIMITED_POLY () needs the _data component to be set, when
5990 expr is a unlimited polymorphic object. But the _data component
5991 has not been set yet, so check the derived type's attr for the
5992 unlimited polymorphic flag to be safe. */
5993 upoly_expr
= UNLIMITED_POLY (expr
)
5994 || (expr
->ts
.type
== BT_DERIVED
5995 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
5996 gfc_init_se (&se
, NULL
);
5998 /* For class types prepare the expressions to ref the _vptr
5999 and the _len component. The latter for unlimited polymorphic
6001 if (expr
->ts
.type
== BT_CLASS
)
6003 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
6004 gfc_add_data_component (expr
);
6005 /* Prep the vptr handle. */
6006 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
6007 gfc_add_vptr_component (expr_ref_vptr
);
6008 se
.want_pointer
= 1;
6009 gfc_conv_expr (&se
, expr_ref_vptr
);
6011 se
.want_pointer
= 0;
6012 gfc_free_expr (expr_ref_vptr
);
6013 /* Allocated unlimited polymorphic objects always have a _len
6017 expr_ref_len
= gfc_copy_expr (al
->expr
);
6018 gfc_add_len_component (expr_ref_len
);
6019 gfc_conv_expr (&se
, expr_ref_len
);
6021 gfc_free_expr (expr_ref_len
);
6024 /* In a loop ensure that all loop variable dependent variables
6025 are initialized at the same spot in all execution paths. */
6029 al_vptr
= al_len
= NULL_TREE
;
6031 se
.want_pointer
= 1;
6032 se
.descriptor_only
= 1;
6034 gfc_conv_expr (&se
, expr
);
6035 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6036 /* se.string_length now stores the .string_length variable of expr
6037 needed to allocate character(len=:) arrays. */
6038 al_len
= se
.string_length
;
6040 al_len_needs_set
= al_len
!= NULL_TREE
;
6041 /* When allocating an array one can not use much of the
6042 pre-evaluated expr3 expressions, because for most of them the
6043 scalarizer is needed which is not available in the pre-evaluation
6044 step. Therefore gfc_array_allocate () is responsible (and able)
6045 to handle the complete array allocation. Only the element size
6046 needs to be provided, which is done most of the time by the
6047 pre-evaluation step. */
6049 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6050 || code
->expr3
->ts
.type
== BT_CLASS
))
6052 /* When al is an array, then the element size for each element
6053 in the array is needed, which is the product of the len and
6054 esize for char arrays. For unlimited polymorphics len can be
6055 zero, therefore take the maximum of len and one. */
6056 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6057 TREE_TYPE (expr3_len
),
6058 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6060 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6061 TREE_TYPE (expr3_esize
), expr3_esize
,
6062 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6066 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6067 label_finish
, tmp
, &nelems
,
6068 e3rhs
? e3rhs
: code
->expr3
,
6069 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6070 code
->expr3
!= NULL
&& e3_is
== E3_DESC
6071 && code
->expr3
->expr_type
== EXPR_ARRAY
))
6073 /* A scalar or derived type. First compute the size to
6076 expr3_len is set when expr3 is an unlimited polymorphic
6077 object or a deferred length string. */
6078 if (expr3_len
!= NULL_TREE
)
6080 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6081 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6082 TREE_TYPE (expr3_esize
),
6084 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6085 /* expr3 is a deferred length string, i.e., we are
6090 /* For unlimited polymorphic enties build
6091 (len > 0) ? element_size * len : element_size
6092 to compute the number of bytes to allocate.
6093 This allows the allocation of unlimited polymorphic
6094 objects from an expr3 that is also unlimited
6095 polymorphic and stores a _len dependent object,
6097 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6098 boolean_type_node
, expr3_len
,
6100 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6101 TREE_TYPE (expr3_esize
),
6102 memsz
, tmp
, expr3_esize
);
6105 else if (expr3_esize
!= NULL_TREE
)
6106 /* Any other object in expr3 just needs element size in
6108 memsz
= expr3_esize
;
6109 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6111 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6113 /* Allocating deferred length char arrays need the length
6114 to allocate in the alloc_type_spec. But also unlimited
6115 polymorphic objects may be allocated as char arrays.
6116 Both are handled here. */
6117 gfc_init_se (&se_sz
, NULL
);
6118 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6119 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6120 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6121 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6122 expr3_len
= se_sz
.expr
;
6123 tmp_expr3_len_flag
= true;
6124 tmp
= TYPE_SIZE_UNIT (
6125 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6126 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6128 fold_convert (TREE_TYPE (tmp
),
6132 else if (expr
->ts
.type
== BT_CHARACTER
)
6134 /* Compute the number of bytes needed to allocate a fixed
6135 length char array. */
6136 gcc_assert (se
.string_length
!= NULL_TREE
);
6137 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6138 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6139 TREE_TYPE (tmp
), tmp
,
6140 fold_convert (TREE_TYPE (tmp
),
6143 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6144 /* Handle all types, where the alloc_type_spec is set. */
6145 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6147 /* Handle size computation of the type declared to alloc. */
6148 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6150 /* Store the caf-attributes for latter use. */
6151 if (flag_coarray
== GFC_FCOARRAY_LIB
6152 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6155 /* Scalar allocatable components in coarray'ed derived types make
6156 it here and are treated now. */
6157 tree caf_decl
, token
;
6161 /* Set flag, to add synchronize after the allocate. */
6162 needs_caf_sync
= needs_caf_sync
6163 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6165 gfc_init_se (&caf_se
, NULL
);
6167 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6168 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6170 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6171 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6172 gfc_build_addr_expr (NULL_TREE
, token
),
6173 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6174 label_finish
, expr
, 1);
6176 /* Allocate - for non-pointers with re-alloc checking. */
6177 else if (gfc_expr_attr (expr
).allocatable
)
6178 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6179 NULL_TREE
, stat
, errmsg
, errlen
,
6180 label_finish
, expr
, 0);
6182 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6186 /* Allocating coarrays needs a sync after the allocate executed.
6187 Set the flag to add the sync after all objects are allocated. */
6188 if (flag_coarray
== GFC_FCOARRAY_LIB
6189 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6193 needs_caf_sync
= needs_caf_sync
6194 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6197 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6198 && expr3_len
!= NULL_TREE
)
6200 /* Arrays need to have a _len set before the array
6201 descriptor is filled. */
6202 gfc_add_modify (&block
, al_len
,
6203 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6204 /* Prevent setting the length twice. */
6205 al_len_needs_set
= false;
6207 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6208 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6210 /* Cover the cases where a string length is explicitly
6211 specified by a type spec for deferred length character
6212 arrays or unlimited polymorphic objects without a
6213 source= or mold= expression. */
6214 gfc_init_se (&se_sz
, NULL
);
6215 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6216 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6217 gfc_add_modify (&block
, al_len
,
6218 fold_convert (TREE_TYPE (al_len
),
6220 al_len_needs_set
= false;
6224 gfc_add_block_to_block (&block
, &se
.pre
);
6226 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6229 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6230 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6231 boolean_type_node
, stat
,
6232 build_int_cst (TREE_TYPE (stat
), 0));
6233 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6234 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6235 tmp
, build_empty_stmt (input_location
));
6236 gfc_add_expr_to_block (&block
, tmp
);
6239 /* Set the vptr only when no source= is set. When source= is set, then
6240 the trans_assignment below will set the vptr. */
6241 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6243 if (expr3_vptr
!= NULL_TREE
)
6244 /* The vtab is already known, so just assign it. */
6245 gfc_add_modify (&block
, al_vptr
,
6246 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6249 /* VPTR is fixed at compile time. */
6254 /* Although expr3 is pre-evaluated above, it may happen,
6255 that for arrays or in mold= cases the pre-evaluation
6256 was not successful. In these rare cases take the vtab
6257 from the typespec of expr3 here. */
6258 ts
= &code
->expr3
->ts
;
6259 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6260 /* The alloc_type_spec gives the type to allocate or the
6261 al is unlimited polymorphic, which enforces the use of
6262 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6263 ts
= &code
->ext
.alloc
.ts
;
6265 /* Prepare for setting the vtab as declared. */
6268 vtab
= gfc_find_vtab (ts
);
6270 tmp
= gfc_build_addr_expr (NULL_TREE
,
6271 gfc_get_symbol_decl (vtab
));
6272 gfc_add_modify (&block
, al_vptr
,
6273 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6277 /* Add assignment for string length. */
6278 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6280 if (expr3_len
!= NULL_TREE
)
6282 gfc_add_modify (&block
, al_len
,
6283 fold_convert (TREE_TYPE (al_len
),
6285 /* When tmp_expr3_len_flag is set, then expr3_len is
6286 abused to carry the length information from the
6287 alloc_type. Clear it to prevent setting incorrect len
6288 information in future loop iterations. */
6289 if (tmp_expr3_len_flag
)
6290 /* No need to reset tmp_expr3_len_flag, because the
6291 presence of an expr3 can not change within in the
6293 expr3_len
= NULL_TREE
;
6295 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6296 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6298 /* Cover the cases where a string length is explicitly
6299 specified by a type spec for deferred length character
6300 arrays or unlimited polymorphic objects without a
6301 source= or mold= expression. */
6302 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6304 gfc_init_se (&se_sz
, NULL
);
6305 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6306 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6307 gfc_add_modify (&block
, al_len
,
6308 fold_convert (TREE_TYPE (al_len
),
6312 gfc_add_modify (&block
, al_len
,
6313 fold_convert (TREE_TYPE (al_len
),
6317 /* No length information needed, because type to allocate
6318 has no length. Set _len to 0. */
6319 gfc_add_modify (&block
, al_len
,
6320 fold_convert (TREE_TYPE (al_len
),
6321 integer_zero_node
));
6325 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6327 /* Initialization via SOURCE block (or static default initializer).
6328 Switch off automatic reallocation since we have just done the
6330 int realloc_lhs
= flag_realloc_lhs
;
6331 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6332 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6333 flag_realloc_lhs
= 0;
6334 tmp
= gfc_trans_assignment (init_expr
, rhs
, false, false, true,
6336 flag_realloc_lhs
= realloc_lhs
;
6337 /* Free the expression allocated for init_expr. */
6338 gfc_free_expr (init_expr
);
6340 gfc_free_expr (rhs
);
6341 gfc_add_expr_to_block (&block
, tmp
);
6343 /* Set KIND and LEN PDT components and allocate those that are
6345 else if (expr
->ts
.type
== BT_DERIVED
6346 && expr
->ts
.u
.derived
->attr
.pdt_type
)
6348 if (code
->expr3
&& code
->expr3
->param_list
)
6349 param_list
= code
->expr3
->param_list
;
6350 else if (expr
->param_list
)
6351 param_list
= expr
->param_list
;
6353 param_list
= expr
->symtree
->n
.sym
->param_list
;
6354 tmp
= gfc_allocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
,
6355 expr
->rank
, param_list
);
6356 gfc_add_expr_to_block (&block
, tmp
);
6358 /* Ditto for CLASS expressions. */
6359 else if (expr
->ts
.type
== BT_CLASS
6360 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
)
6362 if (code
->expr3
&& code
->expr3
->param_list
)
6363 param_list
= code
->expr3
->param_list
;
6364 else if (expr
->param_list
)
6365 param_list
= expr
->param_list
;
6367 param_list
= expr
->symtree
->n
.sym
->param_list
;
6368 tmp
= gfc_allocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6369 se
.expr
, expr
->rank
, param_list
);
6370 gfc_add_expr_to_block (&block
, tmp
);
6372 else if (code
->expr3
&& code
->expr3
->mold
6373 && code
->expr3
->ts
.type
== BT_CLASS
)
6375 /* Use class_init_assign to initialize expr. */
6377 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6378 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
);
6379 tmp
= gfc_trans_class_init_assign (ini
);
6380 gfc_free_statements (ini
);
6381 gfc_add_expr_to_block (&block
, tmp
);
6383 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
6385 /* Use class_init_assign to initialize expr. */
6387 int realloc_lhs
= flag_realloc_lhs
;
6388 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6389 ini
->expr1
= gfc_expr_to_initialize (expr
);
6390 ini
->expr2
= init_expr
;
6391 flag_realloc_lhs
= 0;
6392 tmp
= gfc_trans_init_assign (ini
);
6393 flag_realloc_lhs
= realloc_lhs
;
6394 gfc_free_statements (ini
);
6395 /* Init_expr is freeed by above free_statements, just need to null
6398 gfc_add_expr_to_block (&block
, tmp
);
6401 /* Nullify all pointers in derived type coarrays. This registers a
6402 token for them which allows their allocation. */
6405 gfc_symbol
*type
= NULL
;
6406 symbol_attribute caf_attr
;
6408 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6409 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
6411 type
= code
->ext
.alloc
.ts
.u
.derived
;
6412 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
6413 gfc_clear_attr (&caf_attr
);
6415 else if (expr
->ts
.type
== BT_DERIVED
6416 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
6418 type
= expr
->ts
.u
.derived
;
6420 caf_attr
= gfc_caf_attr (expr
, true);
6423 /* Initialize the tokens of pointer components in derived type
6427 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
6428 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
6429 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
6430 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
6431 gfc_add_expr_to_block (&block
, tmp
);
6435 gfc_free_expr (expr
);
6442 gfc_free_symbol (newsym
->n
.sym
);
6445 gfc_free_expr (e3rhs
);
6450 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6451 gfc_add_expr_to_block (&block
, tmp
);
6454 /* ERRMSG - only useful if STAT is present. */
6455 if (code
->expr1
&& code
->expr2
)
6457 const char *msg
= "Attempt to allocate an allocated object";
6458 tree slen
, dlen
, errmsg_str
;
6459 stmtblock_t errmsg_block
;
6461 gfc_init_block (&errmsg_block
);
6463 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6464 gfc_add_modify (&errmsg_block
, errmsg_str
,
6465 gfc_build_addr_expr (pchar_type_node
,
6466 gfc_build_localized_cstring_const (msg
)));
6468 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6469 dlen
= gfc_get_expr_charlen (code
->expr2
);
6470 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6471 TREE_TYPE (slen
), dlen
, slen
);
6473 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6474 code
->expr2
->ts
.kind
,
6476 gfc_default_character_kind
);
6477 dlen
= gfc_finish_block (&errmsg_block
);
6479 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6480 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6482 tmp
= build3_v (COND_EXPR
, tmp
,
6483 dlen
, build_empty_stmt (input_location
));
6485 gfc_add_expr_to_block (&block
, tmp
);
6491 if (TREE_USED (label_finish
))
6493 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6494 gfc_add_expr_to_block (&block
, tmp
);
6497 gfc_init_se (&se
, NULL
);
6498 gfc_conv_expr_lhs (&se
, code
->expr1
);
6499 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6500 gfc_add_modify (&block
, se
.expr
, tmp
);
6505 /* Add a sync all after the allocation has been executed. */
6506 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
6507 3, null_pointer_node
, null_pointer_node
,
6509 gfc_add_expr_to_block (&post
, tmp
);
6512 gfc_add_block_to_block (&block
, &se
.post
);
6513 gfc_add_block_to_block (&block
, &post
);
6515 return gfc_finish_block (&block
);
6519 /* Translate a DEALLOCATE statement. */
6522 gfc_trans_deallocate (gfc_code
*code
)
6526 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6527 tree label_finish
, label_errmsg
;
6530 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6531 label_finish
= label_errmsg
= NULL_TREE
;
6533 gfc_start_block (&block
);
6535 /* Count the number of failed deallocations. If deallocate() was
6536 called with STAT= , then set STAT to the count. If deallocate
6537 was called with ERRMSG, then set ERRMG to a string. */
6540 tree gfc_int4_type_node
= gfc_get_int_type (4);
6542 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6543 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6545 /* GOTO destinations. */
6546 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6547 label_finish
= gfc_build_label_decl (NULL_TREE
);
6548 TREE_USED (label_finish
) = 0;
6551 /* Set ERRMSG - only needed if STAT is available. */
6552 if (code
->expr1
&& code
->expr2
)
6554 gfc_init_se (&se
, NULL
);
6555 se
.want_pointer
= 1;
6556 gfc_conv_expr_lhs (&se
, code
->expr2
);
6558 errlen
= se
.string_length
;
6561 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6563 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6564 bool is_coarray
= false, is_coarray_array
= false;
6567 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6569 if (expr
->ts
.type
== BT_CLASS
)
6570 gfc_add_data_component (expr
);
6572 gfc_init_se (&se
, NULL
);
6573 gfc_start_block (&se
.pre
);
6575 se
.want_pointer
= 1;
6576 se
.descriptor_only
= 1;
6577 gfc_conv_expr (&se
, expr
);
6579 /* Deallocate PDT components that are parameterized. */
6581 if (expr
->ts
.type
== BT_DERIVED
6582 && expr
->ts
.u
.derived
->attr
.pdt_type
6583 && expr
->symtree
->n
.sym
->param_list
)
6584 tmp
= gfc_deallocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
, expr
->rank
);
6585 else if (expr
->ts
.type
== BT_CLASS
6586 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
6587 && expr
->symtree
->n
.sym
->param_list
)
6588 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6589 se
.expr
, expr
->rank
);
6592 gfc_add_expr_to_block (&block
, tmp
);
6594 if (flag_coarray
== GFC_FCOARRAY_LIB
6595 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
6598 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
6599 if (caf_attr
.codimension
)
6602 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
6603 || caf_attr
.coarray_comp
;
6605 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6606 /* When the expression to deallocate is referencing a
6607 component, then only deallocate it, but do not
6609 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
6610 | (comp_ref
&& !caf_attr
.coarray_comp
6611 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
6615 if (expr
->rank
|| is_coarray_array
)
6619 if (gfc_bt_struct (expr
->ts
.type
)
6620 && expr
->ts
.u
.derived
->attr
.alloc_comp
6621 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6623 gfc_ref
*last
= NULL
;
6625 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6626 if (ref
->type
== REF_COMPONENT
)
6629 /* Do not deallocate the components of a derived type
6630 ultimate pointer component. */
6631 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6632 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6634 if (is_coarray
&& expr
->rank
== 0
6635 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
6636 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6638 /* Add the ref to the data member only, when this is not
6639 a regular array or deallocate_alloc_comp will try to
6641 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
6645 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
6646 expr
->rank
, caf_mode
);
6647 gfc_add_expr_to_block (&se
.pre
, tmp
);
6651 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6653 gfc_coarray_deregtype caf_dtype
;
6656 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
6657 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
6658 : GFC_CAF_COARRAY_DEREGISTER
;
6660 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
6661 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
6662 label_finish
, false, expr
,
6664 gfc_add_expr_to_block (&se
.pre
, tmp
);
6666 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6667 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6668 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6671 /* class.c(finalize_component) generates these, when a
6672 finalizable entity has a non-allocatable derived type array
6673 component, which has allocatable components. Obtain the
6674 derived type of the array and deallocate the allocatable
6676 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6678 if (ref
->u
.c
.component
->attr
.dimension
6679 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6683 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6684 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6687 tmp
= gfc_deallocate_alloc_comp
6688 (ref
->u
.c
.component
->ts
.u
.derived
,
6689 se
.expr
, expr
->rank
);
6690 gfc_add_expr_to_block (&se
.pre
, tmp
);
6694 if (al
->expr
->ts
.type
== BT_CLASS
)
6696 gfc_reset_vptr (&se
.pre
, al
->expr
);
6697 if (UNLIMITED_POLY (al
->expr
)
6698 || (al
->expr
->ts
.type
== BT_DERIVED
6699 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6700 /* Clear _len, too. */
6701 gfc_reset_len (&se
.pre
, al
->expr
);
6706 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
6708 al
->expr
->ts
, is_coarray
);
6709 gfc_add_expr_to_block (&se
.pre
, tmp
);
6711 /* Set to zero after deallocation. */
6712 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6714 build_int_cst (TREE_TYPE (se
.expr
), 0));
6715 gfc_add_expr_to_block (&se
.pre
, tmp
);
6717 if (al
->expr
->ts
.type
== BT_CLASS
)
6719 gfc_reset_vptr (&se
.pre
, al
->expr
);
6720 if (UNLIMITED_POLY (al
->expr
)
6721 || (al
->expr
->ts
.type
== BT_DERIVED
6722 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6723 /* Clear _len, too. */
6724 gfc_reset_len (&se
.pre
, al
->expr
);
6732 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6733 build_int_cst (TREE_TYPE (stat
), 0));
6734 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6735 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6736 build1_v (GOTO_EXPR
, label_errmsg
),
6737 build_empty_stmt (input_location
));
6738 gfc_add_expr_to_block (&se
.pre
, tmp
);
6741 tmp
= gfc_finish_block (&se
.pre
);
6742 gfc_add_expr_to_block (&block
, tmp
);
6743 gfc_free_expr (expr
);
6748 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6749 gfc_add_expr_to_block (&block
, tmp
);
6752 /* Set ERRMSG - only needed if STAT is available. */
6753 if (code
->expr1
&& code
->expr2
)
6755 const char *msg
= "Attempt to deallocate an unallocated object";
6756 stmtblock_t errmsg_block
;
6757 tree errmsg_str
, slen
, dlen
, cond
;
6759 gfc_init_block (&errmsg_block
);
6761 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6762 gfc_add_modify (&errmsg_block
, errmsg_str
,
6763 gfc_build_addr_expr (pchar_type_node
,
6764 gfc_build_localized_cstring_const (msg
)));
6765 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6766 dlen
= gfc_get_expr_charlen (code
->expr2
);
6768 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6769 slen
, errmsg_str
, gfc_default_character_kind
);
6770 tmp
= gfc_finish_block (&errmsg_block
);
6772 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6773 build_int_cst (TREE_TYPE (stat
), 0));
6774 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6775 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6776 build_empty_stmt (input_location
));
6778 gfc_add_expr_to_block (&block
, tmp
);
6781 if (code
->expr1
&& TREE_USED (label_finish
))
6783 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6784 gfc_add_expr_to_block (&block
, tmp
);
6790 gfc_init_se (&se
, NULL
);
6791 gfc_conv_expr_lhs (&se
, code
->expr1
);
6792 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6793 gfc_add_modify (&block
, se
.expr
, tmp
);
6796 return gfc_finish_block (&block
);
6799 #include "gt-fortran-trans-stmt.h"