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;
1536 symbol_attribute attr
;
1538 gcc_assert (sym
->assoc
);
1539 e
= sym
->assoc
->target
;
1541 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1542 && (gfc_is_class_scalar_expr (e
)
1543 || gfc_is_class_array_ref (e
, NULL
));
1545 unlimited
= UNLIMITED_POLY (e
);
1547 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1548 if (ref
->type
== REF_ARRAY
1549 && ref
->u
.ar
.type
== AR_FULL
1552 whole_array
= false;
1556 /* Assignments to the string length need to be generated, when
1557 ( sym is a char array or
1558 sym has a _len component)
1559 and the associated expression is unlimited polymorphic, which is
1560 not (yet) correctly in 'unlimited', because for an already associated
1561 BT_DERIVED the u-poly flag is not set, i.e.,
1562 __tmp_CHARACTER_0_1 => w => arg
1563 ^ generated temp ^ from code, the w does not have the u-poly
1564 flag set, where UNLIMITED_POLY(e) expects it. */
1565 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1566 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1567 && (sym
->ts
.type
== BT_CHARACTER
1568 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1569 && class_has_len_component (sym
))));
1570 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1571 to array temporary) for arrays with either unknown shape or if associating
1573 if (sym
->attr
.dimension
&& !class_target
1574 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1578 bool cst_array_ctor
;
1580 desc
= sym
->backend_decl
;
1581 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1582 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1584 /* If association is to an expression, evaluate it and create temporary.
1585 Otherwise, get descriptor of target for pointer assignment. */
1586 gfc_init_se (&se
, NULL
);
1587 if (sym
->assoc
->variable
|| cst_array_ctor
)
1589 se
.direct_byref
= 1;
1594 gfc_conv_expr_descriptor (&se
, e
);
1596 if (sym
->ts
.type
== BT_CHARACTER
1598 && !sym
->attr
.select_type_temporary
1599 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1600 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1602 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1603 fold_convert (gfc_charlen_type_node
,
1607 /* If we didn't already do the pointer assignment, set associate-name
1608 descriptor to the one generated for the temporary. */
1609 if ((!sym
->assoc
->variable
&& !cst_array_ctor
)
1615 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1617 /* The generated descriptor has lower bound zero (as array
1618 temporary), shift bounds so we get lower bounds of 1. */
1619 for (dim
= 0; dim
< e
->rank
; ++dim
)
1620 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1621 dim
, gfc_index_one_node
);
1624 /* If this is a subreference array pointer associate name use the
1625 associate variable element size for the value of 'span'. */
1626 if (sym
->attr
.subref_array_pointer
)
1628 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1629 tmp
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1630 ? gfc_class_data_get (e
->symtree
->n
.sym
->backend_decl
)
1631 : e
->symtree
->n
.sym
->backend_decl
;
1632 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1633 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1634 gfc_conv_descriptor_span_set (&se
.pre
, desc
, tmp
);
1637 /* Done, register stuff as init / cleanup code. */
1638 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1639 gfc_finish_block (&se
.post
));
1642 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1643 arrays to be assigned directly. */
1644 else if (class_target
&& sym
->attr
.dimension
1645 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1649 gfc_init_se (&se
, NULL
);
1650 se
.descriptor_only
= 1;
1651 /* In a select type the (temporary) associate variable shall point to
1652 a standard fortran array (lower bound == 1), but conv_expr ()
1653 just maps to the input array in the class object, whose lbound may
1654 be arbitrary. conv_expr_descriptor solves this by inserting a
1655 temporary array descriptor. */
1656 gfc_conv_expr_descriptor (&se
, e
);
1658 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1659 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1660 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1662 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1664 if (INDIRECT_REF_P (se
.expr
))
1665 tmp
= TREE_OPERAND (se
.expr
, 0);
1669 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1670 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1673 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1677 /* Recover the dtype, which has been overwritten by the
1678 assignment from an unlimited polymorphic object. */
1679 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1680 gfc_add_modify (&se
.pre
, tmp
,
1681 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1684 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1685 gfc_finish_block (&se
.post
));
1688 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1689 else if (gfc_is_associate_pointer (sym
))
1693 gcc_assert (!sym
->attr
.dimension
);
1695 gfc_init_se (&se
, NULL
);
1697 /* Class associate-names come this way because they are
1698 unconditionally associate pointers and the symbol is scalar. */
1699 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1702 /* For a class array we need a descriptor for the selector. */
1703 gfc_conv_expr_descriptor (&se
, e
);
1704 /* Needed to get/set the _len component below. */
1705 target_expr
= se
.expr
;
1707 /* Obtain a temporary class container for the result. */
1708 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1709 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1711 /* Set the offset. */
1712 desc
= gfc_class_data_get (se
.expr
);
1713 offset
= gfc_index_zero_node
;
1714 for (n
= 0; n
< e
->rank
; n
++)
1716 dim
= gfc_rank_cst
[n
];
1717 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1718 gfc_array_index_type
,
1719 gfc_conv_descriptor_stride_get (desc
, dim
),
1720 gfc_conv_descriptor_lbound_get (desc
, dim
));
1721 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1722 gfc_array_index_type
,
1725 if (need_len_assign
)
1728 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1729 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1730 /* Use the original class descriptor stored in the saved
1731 descriptor to get the target_expr. */
1733 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1735 /* Strip the _data component from the target_expr. */
1736 target_expr
= TREE_OPERAND (target_expr
, 0);
1737 /* Add a reference to the _len comp to the target expr. */
1738 tmp
= gfc_class_len_get (target_expr
);
1739 /* Get the component-ref for the temp structure's _len comp. */
1740 charlen
= gfc_class_len_get (se
.expr
);
1741 /* Add the assign to the beginning of the block... */
1742 gfc_add_modify (&se
.pre
, charlen
,
1743 fold_convert (TREE_TYPE (charlen
), tmp
));
1744 /* and the oposite way at the end of the block, to hand changes
1745 on the string length back. */
1746 gfc_add_modify (&se
.post
, tmp
,
1747 fold_convert (TREE_TYPE (tmp
), charlen
));
1748 /* Length assignment done, prevent adding it again below. */
1749 need_len_assign
= false;
1751 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1753 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1754 && CLASS_DATA (e
)->attr
.dimension
)
1756 /* This is bound to be a class array element. */
1757 gfc_conv_expr_reference (&se
, e
);
1758 /* Get the _vptr component of the class object. */
1759 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1760 /* Obtain a temporary class container for the result. */
1761 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1762 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1766 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1767 which has the string length included. For CHARACTERS it is still
1768 needed and will be done at the end of this routine. */
1769 gfc_conv_expr (&se
, e
);
1770 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1773 if (sym
->ts
.type
== BT_CHARACTER
1775 && !sym
->attr
.select_type_temporary
1776 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1777 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1779 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1780 fold_convert (gfc_charlen_type_node
,
1782 if (e
->expr_type
== EXPR_FUNCTION
)
1784 tmp
= gfc_call_free (sym
->backend_decl
);
1785 gfc_add_expr_to_block (&se
.post
, tmp
);
1789 attr
= gfc_expr_attr (e
);
1790 if (sym
->ts
.type
== BT_CHARACTER
&& e
->ts
.type
== BT_CHARACTER
1791 && (attr
.allocatable
|| attr
.pointer
|| attr
.dummy
))
1793 /* These are pointer types already. */
1794 tmp
= fold_convert (TREE_TYPE (sym
->backend_decl
), se
.expr
);
1798 tmp
= TREE_TYPE (sym
->backend_decl
);
1799 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1802 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1804 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1805 gfc_finish_block (&se
.post
));
1808 /* Do a simple assignment. This is for scalar expressions, where we
1809 can simply use expression assignment. */
1814 lhs
= gfc_lval_expr_from_sym (sym
);
1815 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1816 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1819 /* Set the stringlength, when needed. */
1820 if (need_len_assign
)
1823 gfc_init_se (&se
, NULL
);
1824 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1826 /* Deferred strings are dealt with in the preceeding. */
1827 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1828 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1831 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1832 gfc_get_symbol_decl (sym
);
1833 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1834 : gfc_class_len_get (sym
->backend_decl
);
1835 /* Prevent adding a noop len= len. */
1838 gfc_add_modify (&se
.pre
, charlen
,
1839 fold_convert (TREE_TYPE (charlen
), tmp
));
1840 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1841 gfc_finish_block (&se
.post
));
1847 /* Translate a BLOCK construct. This is basically what we would do for a
1851 gfc_trans_block_construct (gfc_code
* code
)
1855 gfc_wrapped_block block
;
1858 gfc_association_list
*ass
;
1860 ns
= code
->ext
.block
.ns
;
1862 sym
= ns
->proc_name
;
1865 /* Process local variables. */
1866 gcc_assert (!sym
->tlink
);
1868 gfc_process_block_locals (ns
);
1870 /* Generate code including exit-label. */
1871 gfc_init_block (&body
);
1872 exit_label
= gfc_build_label_decl (NULL_TREE
);
1873 code
->exit_label
= exit_label
;
1875 finish_oacc_declare (ns
, sym
, true);
1877 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1878 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1880 /* Finish everything. */
1881 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1882 gfc_trans_deferred_vars (sym
, &block
);
1883 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1884 trans_associate_var (ass
->st
->n
.sym
, &block
);
1886 return gfc_finish_wrapped_block (&block
);
1889 /* Translate the simple DO construct in a C-style manner.
1890 This is where the loop variable has integer type and step +-1.
1891 Following code will generate infinite loop in case where TO is INT_MAX
1892 (for +1 step) or INT_MIN (for -1 step)
1894 We translate a do loop from:
1896 DO dovar = from, to, step
1902 [Evaluate loop bounds and step]
1914 This helps the optimizers by avoiding the extra pre-header condition and
1915 we save a register as we just compare the updated IV (not a value in
1919 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1920 tree from
, tree to
, tree step
, tree exit_cond
)
1926 tree saved_dovar
= NULL
;
1930 type
= TREE_TYPE (dovar
);
1931 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
1933 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1935 /* Initialize the DO variable: dovar = from. */
1936 gfc_add_modify_loc (loc
, pblock
, dovar
,
1937 fold_convert (TREE_TYPE (dovar
), from
));
1939 /* Save value for do-tinkering checking. */
1940 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1942 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1943 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1946 /* Cycle and exit statements are implemented with gotos. */
1947 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1948 exit_label
= gfc_build_label_decl (NULL_TREE
);
1950 /* Put the labels where they can be found later. See gfc_trans_do(). */
1951 code
->cycle_label
= cycle_label
;
1952 code
->exit_label
= exit_label
;
1955 gfc_start_block (&body
);
1957 /* Exit the loop if there is an I/O result condition or error. */
1960 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1961 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1963 build_empty_stmt (loc
));
1964 gfc_add_expr_to_block (&body
, tmp
);
1967 /* Evaluate the loop condition. */
1968 if (is_step_positive
)
1969 cond
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, dovar
,
1970 fold_convert (type
, to
));
1972 cond
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, dovar
,
1973 fold_convert (type
, to
));
1975 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1977 /* The loop exit. */
1978 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1979 TREE_USED (exit_label
) = 1;
1980 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1981 cond
, tmp
, build_empty_stmt (loc
));
1982 gfc_add_expr_to_block (&body
, tmp
);
1984 /* Check whether the induction variable is equal to INT_MAX
1985 (respectively to INT_MIN). */
1986 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1988 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
1989 : TYPE_MIN_VALUE (type
);
1991 tmp
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
,
1993 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1994 "Loop iterates infinitely");
1997 /* Main loop body. */
1998 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1999 gfc_add_expr_to_block (&body
, tmp
);
2001 /* Label for cycle statements (if needed). */
2002 if (TREE_USED (cycle_label
))
2004 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2005 gfc_add_expr_to_block (&body
, tmp
);
2008 /* Check whether someone has modified the loop variable. */
2009 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2011 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
2012 dovar
, saved_dovar
);
2013 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2014 "Loop variable has been modified");
2017 /* Increment the loop variable. */
2018 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2019 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2021 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2022 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2024 /* Finish the loop body. */
2025 tmp
= gfc_finish_block (&body
);
2026 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2028 gfc_add_expr_to_block (pblock
, tmp
);
2030 /* Add the exit label. */
2031 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2032 gfc_add_expr_to_block (pblock
, tmp
);
2034 return gfc_finish_block (pblock
);
2037 /* Translate the DO construct. This obviously is one of the most
2038 important ones to get right with any compiler, but especially
2041 We special case some loop forms as described in gfc_trans_simple_do.
2042 For other cases we implement them with a separate loop count,
2043 as described in the standard.
2045 We translate a do loop from:
2047 DO dovar = from, to, step
2053 [evaluate loop bounds and step]
2054 empty = (step > 0 ? to < from : to > from);
2055 countm1 = (to - from) / step;
2057 if (empty) goto exit_label;
2065 if (countm1t == 0) goto exit_label;
2069 countm1 is an unsigned integer. It is equal to the loop count minus one,
2070 because the loop count itself can overflow. */
2073 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2077 tree saved_dovar
= NULL
;
2092 gfc_start_block (&block
);
2094 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2096 /* Evaluate all the expressions in the iterator. */
2097 gfc_init_se (&se
, NULL
);
2098 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2099 gfc_add_block_to_block (&block
, &se
.pre
);
2101 type
= TREE_TYPE (dovar
);
2103 gfc_init_se (&se
, NULL
);
2104 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2105 gfc_add_block_to_block (&block
, &se
.pre
);
2106 from
= gfc_evaluate_now (se
.expr
, &block
);
2108 gfc_init_se (&se
, NULL
);
2109 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2110 gfc_add_block_to_block (&block
, &se
.pre
);
2111 to
= gfc_evaluate_now (se
.expr
, &block
);
2113 gfc_init_se (&se
, NULL
);
2114 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2115 gfc_add_block_to_block (&block
, &se
.pre
);
2116 step
= gfc_evaluate_now (se
.expr
, &block
);
2118 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2120 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
2121 build_zero_cst (type
));
2122 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2123 "DO step value is zero");
2126 /* Special case simple loops. */
2127 if (TREE_CODE (type
) == INTEGER_TYPE
2128 && (integer_onep (step
)
2129 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2130 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2133 if (TREE_CODE (type
) == INTEGER_TYPE
)
2134 utype
= unsigned_type_for (type
);
2136 utype
= unsigned_type_for (gfc_array_index_type
);
2137 countm1
= gfc_create_var (utype
, "countm1");
2139 /* Cycle and exit statements are implemented with gotos. */
2140 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2141 exit_label
= gfc_build_label_decl (NULL_TREE
);
2142 TREE_USED (exit_label
) = 1;
2144 /* Put these labels where they can be found later. */
2145 code
->cycle_label
= cycle_label
;
2146 code
->exit_label
= exit_label
;
2148 /* Initialize the DO variable: dovar = from. */
2149 gfc_add_modify (&block
, dovar
, from
);
2151 /* Save value for do-tinkering checking. */
2152 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2154 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2155 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2158 /* Initialize loop count and jump to exit label if the loop is empty.
2159 This code is executed before we enter the loop body. We generate:
2162 countm1 = (to - from) / step;
2168 countm1 = (from - to) / -step;
2174 if (TREE_CODE (type
) == INTEGER_TYPE
)
2176 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2178 /* The distance from FROM to TO cannot always be represented in a signed
2179 type, thus use unsigned arithmetic, also to avoid any undefined
2181 tou
= fold_convert (utype
, to
);
2182 fromu
= fold_convert (utype
, from
);
2183 stepu
= fold_convert (utype
, step
);
2185 /* For a positive step, when to < from, exit, otherwise compute
2186 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2187 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
2188 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2189 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2192 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2193 fold_build2 (MODIFY_EXPR
, void_type_node
,
2195 build3_loc (loc
, COND_EXPR
, void_type_node
,
2196 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2197 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2198 exit_label
), NULL_TREE
));
2200 /* For a negative step, when to > from, exit, otherwise compute
2201 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2202 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
2203 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2204 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2206 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2207 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2208 fold_build2 (MODIFY_EXPR
, void_type_node
,
2210 build3_loc (loc
, COND_EXPR
, void_type_node
,
2211 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2212 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2213 exit_label
), NULL_TREE
));
2215 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
2216 build_int_cst (TREE_TYPE (step
), 0));
2217 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2219 gfc_add_expr_to_block (&block
, tmp
);
2225 /* TODO: We could use the same width as the real type.
2226 This would probably cause more problems that it solves
2227 when we implement "long double" types. */
2229 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2230 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2231 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2232 gfc_add_modify (&block
, countm1
, tmp
);
2234 /* We need a special check for empty loops:
2235 empty = (step > 0 ? to < from : to > from); */
2236 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
2237 build_zero_cst (type
));
2238 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
2239 fold_build2_loc (loc
, LT_EXPR
,
2240 boolean_type_node
, to
, from
),
2241 fold_build2_loc (loc
, GT_EXPR
,
2242 boolean_type_node
, to
, from
));
2243 /* If the loop is empty, go directly to the exit label. */
2244 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2245 build1_v (GOTO_EXPR
, exit_label
),
2246 build_empty_stmt (input_location
));
2247 gfc_add_expr_to_block (&block
, tmp
);
2251 gfc_start_block (&body
);
2253 /* Main loop body. */
2254 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2255 gfc_add_expr_to_block (&body
, tmp
);
2257 /* Label for cycle statements (if needed). */
2258 if (TREE_USED (cycle_label
))
2260 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2261 gfc_add_expr_to_block (&body
, tmp
);
2264 /* Check whether someone has modified the loop variable. */
2265 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2267 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
2269 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2270 "Loop variable has been modified");
2273 /* Exit the loop if there is an I/O result condition or error. */
2276 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2277 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2279 build_empty_stmt (input_location
));
2280 gfc_add_expr_to_block (&body
, tmp
);
2283 /* Increment the loop variable. */
2284 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2285 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2287 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2288 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2290 /* Initialize countm1t. */
2291 tree countm1t
= gfc_create_var (utype
, "countm1t");
2292 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2294 /* Decrement the loop count. */
2295 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2296 build_int_cst (utype
, 1));
2297 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2299 /* End with the loop condition. Loop until countm1t == 0. */
2300 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
2301 build_int_cst (utype
, 0));
2302 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2303 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2304 cond
, tmp
, build_empty_stmt (loc
));
2305 gfc_add_expr_to_block (&body
, tmp
);
2307 /* End of loop body. */
2308 tmp
= gfc_finish_block (&body
);
2310 /* The for loop itself. */
2311 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2312 gfc_add_expr_to_block (&block
, tmp
);
2314 /* Add the exit label. */
2315 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2316 gfc_add_expr_to_block (&block
, tmp
);
2318 return gfc_finish_block (&block
);
2322 /* Translate the DO WHILE construct.
2335 if (! cond) goto exit_label;
2341 Because the evaluation of the exit condition `cond' may have side
2342 effects, we can't do much for empty loop bodies. The backend optimizers
2343 should be smart enough to eliminate any dead loops. */
2346 gfc_trans_do_while (gfc_code
* code
)
2354 /* Everything we build here is part of the loop body. */
2355 gfc_start_block (&block
);
2357 /* Cycle and exit statements are implemented with gotos. */
2358 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2359 exit_label
= gfc_build_label_decl (NULL_TREE
);
2361 /* Put the labels where they can be found later. See gfc_trans_do(). */
2362 code
->cycle_label
= cycle_label
;
2363 code
->exit_label
= exit_label
;
2365 /* Create a GIMPLE version of the exit condition. */
2366 gfc_init_se (&cond
, NULL
);
2367 gfc_conv_expr_val (&cond
, code
->expr1
);
2368 gfc_add_block_to_block (&block
, &cond
.pre
);
2369 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2370 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2372 /* Build "IF (! cond) GOTO exit_label". */
2373 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2374 TREE_USED (exit_label
) = 1;
2375 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2376 void_type_node
, cond
.expr
, tmp
,
2377 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2378 gfc_add_expr_to_block (&block
, tmp
);
2380 /* The main body of the loop. */
2381 tmp
= gfc_trans_code (code
->block
->next
);
2382 gfc_add_expr_to_block (&block
, tmp
);
2384 /* Label for cycle statements (if needed). */
2385 if (TREE_USED (cycle_label
))
2387 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2388 gfc_add_expr_to_block (&block
, tmp
);
2391 /* End of loop body. */
2392 tmp
= gfc_finish_block (&block
);
2394 gfc_init_block (&block
);
2395 /* Build the loop. */
2396 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2397 void_type_node
, tmp
);
2398 gfc_add_expr_to_block (&block
, tmp
);
2400 /* Add the exit label. */
2401 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2402 gfc_add_expr_to_block (&block
, tmp
);
2404 return gfc_finish_block (&block
);
2408 /* Deal with the particular case of SELECT_TYPE, where the vtable
2409 addresses are used for the selection. Since these are not sorted,
2410 the selection has to be made by a series of if statements. */
2413 gfc_trans_select_type_cases (gfc_code
* code
)
2427 gfc_start_block (&block
);
2429 /* Calculate the switch expression. */
2430 gfc_init_se (&se
, NULL
);
2431 gfc_conv_expr_val (&se
, code
->expr1
);
2432 gfc_add_block_to_block (&block
, &se
.pre
);
2434 /* Generate an expression for the selector hash value, for
2435 use to resolve character cases. */
2436 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2437 gfc_add_hash_component (e
);
2439 TREE_USED (code
->exit_label
) = 0;
2442 for (c
= code
->block
; c
; c
= c
->block
)
2444 cp
= c
->ext
.block
.case_list
;
2446 /* Assume it's the default case. */
2451 /* Put the default case at the end. */
2452 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2455 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2456 || cp
->ts
.type
== BT_DERIVED
))
2458 gfc_init_se (&cse
, NULL
);
2459 gfc_conv_expr_val (&cse
, cp
->low
);
2460 gfc_add_block_to_block (&block
, &cse
.pre
);
2463 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2465 gcc_assert (cp
->high
);
2466 gfc_init_se (&cse
, NULL
);
2467 gfc_conv_expr_val (&cse
, cp
->high
);
2468 gfc_add_block_to_block (&block
, &cse
.pre
);
2472 gfc_init_block (&body
);
2474 /* Add the statements for this case. */
2475 tmp
= gfc_trans_code (c
->next
);
2476 gfc_add_expr_to_block (&body
, tmp
);
2478 /* Break to the end of the SELECT TYPE construct. The default
2479 case just falls through. */
2482 TREE_USED (code
->exit_label
) = 1;
2483 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2484 gfc_add_expr_to_block (&body
, tmp
);
2487 tmp
= gfc_finish_block (&body
);
2489 if (low
!= NULL_TREE
)
2491 /* Compare vtable pointers. */
2492 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2493 TREE_TYPE (se
.expr
), se
.expr
, low
);
2494 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2496 build_empty_stmt (input_location
));
2498 else if (high
!= NULL_TREE
)
2500 /* Compare hash values for character cases. */
2501 gfc_init_se (&cse
, NULL
);
2502 gfc_conv_expr_val (&cse
, e
);
2503 gfc_add_block_to_block (&block
, &cse
.pre
);
2505 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2506 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2507 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2509 build_empty_stmt (input_location
));
2512 gfc_add_expr_to_block (&block
, tmp
);
2523 return gfc_finish_block (&block
);
2527 /* Translate the SELECT CASE construct for INTEGER case expressions,
2528 without killing all potential optimizations. The problem is that
2529 Fortran allows unbounded cases, but the back-end does not, so we
2530 need to intercept those before we enter the equivalent SWITCH_EXPR
2533 For example, we translate this,
2536 CASE (:100,101,105:115)
2546 to the GENERIC equivalent,
2550 case (minimum value for typeof(expr) ... 100:
2556 case 200 ... (maximum value for typeof(expr):
2573 gfc_trans_integer_select (gfc_code
* code
)
2583 gfc_start_block (&block
);
2585 /* Calculate the switch expression. */
2586 gfc_init_se (&se
, NULL
);
2587 gfc_conv_expr_val (&se
, code
->expr1
);
2588 gfc_add_block_to_block (&block
, &se
.pre
);
2590 end_label
= gfc_build_label_decl (NULL_TREE
);
2592 gfc_init_block (&body
);
2594 for (c
= code
->block
; c
; c
= c
->block
)
2596 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2601 /* Assume it's the default case. */
2602 low
= high
= NULL_TREE
;
2606 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2609 /* If there's only a lower bound, set the high bound to the
2610 maximum value of the case expression. */
2612 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2617 /* Three cases are possible here:
2619 1) There is no lower bound, e.g. CASE (:N).
2620 2) There is a lower bound .NE. high bound, that is
2621 a case range, e.g. CASE (N:M) where M>N (we make
2622 sure that M>N during type resolution).
2623 3) There is a lower bound, and it has the same value
2624 as the high bound, e.g. CASE (N:N). This is our
2625 internal representation of CASE(N).
2627 In the first and second case, we need to set a value for
2628 high. In the third case, we don't because the GCC middle
2629 end represents a single case value by just letting high be
2630 a NULL_TREE. We can't do that because we need to be able
2631 to represent unbounded cases. */
2634 || (mpz_cmp (cp
->low
->value
.integer
,
2635 cp
->high
->value
.integer
) != 0))
2636 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2639 /* Unbounded case. */
2641 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2644 /* Build a label. */
2645 label
= gfc_build_label_decl (NULL_TREE
);
2647 /* Add this case label.
2648 Add parameter 'label', make it match GCC backend. */
2649 tmp
= build_case_label (low
, high
, label
);
2650 gfc_add_expr_to_block (&body
, tmp
);
2653 /* Add the statements for this case. */
2654 tmp
= gfc_trans_code (c
->next
);
2655 gfc_add_expr_to_block (&body
, tmp
);
2657 /* Break to the end of the construct. */
2658 tmp
= build1_v (GOTO_EXPR
, end_label
);
2659 gfc_add_expr_to_block (&body
, tmp
);
2662 tmp
= gfc_finish_block (&body
);
2663 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2664 se
.expr
, tmp
, NULL_TREE
);
2665 gfc_add_expr_to_block (&block
, tmp
);
2667 tmp
= build1_v (LABEL_EXPR
, end_label
);
2668 gfc_add_expr_to_block (&block
, tmp
);
2670 return gfc_finish_block (&block
);
2674 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2676 There are only two cases possible here, even though the standard
2677 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2678 .FALSE., and DEFAULT.
2680 We never generate more than two blocks here. Instead, we always
2681 try to eliminate the DEFAULT case. This way, we can translate this
2682 kind of SELECT construct to a simple
2686 expression in GENERIC. */
2689 gfc_trans_logical_select (gfc_code
* code
)
2692 gfc_code
*t
, *f
, *d
;
2697 /* Assume we don't have any cases at all. */
2700 /* Now see which ones we actually do have. We can have at most two
2701 cases in a single case list: one for .TRUE. and one for .FALSE.
2702 The default case is always separate. If the cases for .TRUE. and
2703 .FALSE. are in the same case list, the block for that case list
2704 always executed, and we don't generate code a COND_EXPR. */
2705 for (c
= code
->block
; c
; c
= c
->block
)
2707 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2711 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2713 else /* if (cp->value.logical != 0), thus .TRUE. */
2721 /* Start a new block. */
2722 gfc_start_block (&block
);
2724 /* Calculate the switch expression. We always need to do this
2725 because it may have side effects. */
2726 gfc_init_se (&se
, NULL
);
2727 gfc_conv_expr_val (&se
, code
->expr1
);
2728 gfc_add_block_to_block (&block
, &se
.pre
);
2730 if (t
== f
&& t
!= NULL
)
2732 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2733 translate the code for these cases, append it to the current
2735 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2739 tree true_tree
, false_tree
, stmt
;
2741 true_tree
= build_empty_stmt (input_location
);
2742 false_tree
= build_empty_stmt (input_location
);
2744 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2745 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2746 make the missing case the default case. */
2747 if (t
!= NULL
&& f
!= NULL
)
2757 /* Translate the code for each of these blocks, and append it to
2758 the current block. */
2760 true_tree
= gfc_trans_code (t
->next
);
2763 false_tree
= gfc_trans_code (f
->next
);
2765 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2766 se
.expr
, true_tree
, false_tree
);
2767 gfc_add_expr_to_block (&block
, stmt
);
2770 return gfc_finish_block (&block
);
2774 /* The jump table types are stored in static variables to avoid
2775 constructing them from scratch every single time. */
2776 static GTY(()) tree select_struct
[2];
2778 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2779 Instead of generating compares and jumps, it is far simpler to
2780 generate a data structure describing the cases in order and call a
2781 library subroutine that locates the right case.
2782 This is particularly true because this is the only case where we
2783 might have to dispose of a temporary.
2784 The library subroutine returns a pointer to jump to or NULL if no
2785 branches are to be taken. */
2788 gfc_trans_character_select (gfc_code
*code
)
2790 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2791 stmtblock_t block
, body
;
2796 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2798 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2800 /* The jump table types are stored in static variables to avoid
2801 constructing them from scratch every single time. */
2802 static tree ss_string1
[2], ss_string1_len
[2];
2803 static tree ss_string2
[2], ss_string2_len
[2];
2804 static tree ss_target
[2];
2806 cp
= code
->block
->ext
.block
.case_list
;
2807 while (cp
->left
!= NULL
)
2810 /* Generate the body */
2811 gfc_start_block (&block
);
2812 gfc_init_se (&expr1se
, NULL
);
2813 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2815 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2817 end_label
= gfc_build_label_decl (NULL_TREE
);
2819 gfc_init_block (&body
);
2821 /* Attempt to optimize length 1 selects. */
2822 if (integer_onep (expr1se
.string_length
))
2824 for (d
= cp
; d
; d
= d
->right
)
2829 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2830 && d
->low
->ts
.type
== BT_CHARACTER
);
2831 if (d
->low
->value
.character
.length
> 1)
2833 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2834 if (d
->low
->value
.character
.string
[i
] != ' ')
2836 if (i
!= d
->low
->value
.character
.length
)
2838 if (optimize
&& d
->high
&& i
== 1)
2840 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2841 && d
->high
->ts
.type
== BT_CHARACTER
);
2842 if (d
->high
->value
.character
.length
> 1
2843 && (d
->low
->value
.character
.string
[0]
2844 == d
->high
->value
.character
.string
[0])
2845 && d
->high
->value
.character
.string
[1] != ' '
2846 && ((d
->low
->value
.character
.string
[1] < ' ')
2847 == (d
->high
->value
.character
.string
[1]
2857 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2858 && d
->high
->ts
.type
== BT_CHARACTER
);
2859 if (d
->high
->value
.character
.length
> 1)
2861 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2862 if (d
->high
->value
.character
.string
[i
] != ' ')
2864 if (i
!= d
->high
->value
.character
.length
)
2871 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2873 for (c
= code
->block
; c
; c
= c
->block
)
2875 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2881 /* Assume it's the default case. */
2882 low
= high
= NULL_TREE
;
2886 /* CASE ('ab') or CASE ('ab':'az') will never match
2887 any length 1 character. */
2888 if (cp
->low
->value
.character
.length
> 1
2889 && cp
->low
->value
.character
.string
[1] != ' ')
2892 if (cp
->low
->value
.character
.length
> 0)
2893 r
= cp
->low
->value
.character
.string
[0];
2896 low
= build_int_cst (ctype
, r
);
2898 /* If there's only a lower bound, set the high bound
2899 to the maximum value of the case expression. */
2901 high
= TYPE_MAX_VALUE (ctype
);
2907 || (cp
->low
->value
.character
.string
[0]
2908 != cp
->high
->value
.character
.string
[0]))
2910 if (cp
->high
->value
.character
.length
> 0)
2911 r
= cp
->high
->value
.character
.string
[0];
2914 high
= build_int_cst (ctype
, r
);
2917 /* Unbounded case. */
2919 low
= TYPE_MIN_VALUE (ctype
);
2922 /* Build a label. */
2923 label
= gfc_build_label_decl (NULL_TREE
);
2925 /* Add this case label.
2926 Add parameter 'label', make it match GCC backend. */
2927 tmp
= build_case_label (low
, high
, label
);
2928 gfc_add_expr_to_block (&body
, tmp
);
2931 /* Add the statements for this case. */
2932 tmp
= gfc_trans_code (c
->next
);
2933 gfc_add_expr_to_block (&body
, tmp
);
2935 /* Break to the end of the construct. */
2936 tmp
= build1_v (GOTO_EXPR
, end_label
);
2937 gfc_add_expr_to_block (&body
, tmp
);
2940 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2942 code
->expr1
->ts
.kind
);
2943 case_num
= gfc_create_var (ctype
, "case_num");
2944 gfc_add_modify (&block
, case_num
, tmp
);
2946 gfc_add_block_to_block (&block
, &expr1se
.post
);
2948 tmp
= gfc_finish_block (&body
);
2949 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2950 case_num
, tmp
, NULL_TREE
);
2951 gfc_add_expr_to_block (&block
, tmp
);
2953 tmp
= build1_v (LABEL_EXPR
, end_label
);
2954 gfc_add_expr_to_block (&block
, tmp
);
2956 return gfc_finish_block (&block
);
2960 if (code
->expr1
->ts
.kind
== 1)
2962 else if (code
->expr1
->ts
.kind
== 4)
2967 if (select_struct
[k
] == NULL
)
2970 select_struct
[k
] = make_node (RECORD_TYPE
);
2972 if (code
->expr1
->ts
.kind
== 1)
2973 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2974 else if (code
->expr1
->ts
.kind
== 4)
2975 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2980 #define ADD_FIELD(NAME, TYPE) \
2981 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2982 get_identifier (stringize(NAME)), \
2986 ADD_FIELD (string1
, pchartype
);
2987 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2989 ADD_FIELD (string2
, pchartype
);
2990 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2992 ADD_FIELD (target
, integer_type_node
);
2995 gfc_finish_type (select_struct
[k
]);
2999 for (d
= cp
; d
; d
= d
->right
)
3002 for (c
= code
->block
; c
; c
= c
->block
)
3004 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
3006 label
= gfc_build_label_decl (NULL_TREE
);
3007 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
3009 : build_int_cst (integer_type_node
, d
->n
),
3011 gfc_add_expr_to_block (&body
, tmp
);
3014 tmp
= gfc_trans_code (c
->next
);
3015 gfc_add_expr_to_block (&body
, tmp
);
3017 tmp
= build1_v (GOTO_EXPR
, end_label
);
3018 gfc_add_expr_to_block (&body
, tmp
);
3021 /* Generate the structure describing the branches */
3022 for (d
= cp
; d
; d
= d
->right
)
3024 vec
<constructor_elt
, va_gc
> *node
= NULL
;
3026 gfc_init_se (&se
, NULL
);
3030 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
3031 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
3035 gfc_conv_expr_reference (&se
, d
->low
);
3037 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
3038 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
3041 if (d
->high
== NULL
)
3043 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
3044 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
3048 gfc_init_se (&se
, NULL
);
3049 gfc_conv_expr_reference (&se
, d
->high
);
3051 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
3052 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
3055 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
3056 build_int_cst (integer_type_node
, d
->n
));
3058 tmp
= build_constructor (select_struct
[k
], node
);
3059 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
3062 type
= build_array_type (select_struct
[k
],
3063 build_index_type (size_int (n
-1)));
3065 init
= build_constructor (type
, inits
);
3066 TREE_CONSTANT (init
) = 1;
3067 TREE_STATIC (init
) = 1;
3068 /* Create a static variable to hold the jump table. */
3069 tmp
= gfc_create_var (type
, "jumptable");
3070 TREE_CONSTANT (tmp
) = 1;
3071 TREE_STATIC (tmp
) = 1;
3072 TREE_READONLY (tmp
) = 1;
3073 DECL_INITIAL (tmp
) = init
;
3076 /* Build the library call */
3077 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3079 if (code
->expr1
->ts
.kind
== 1)
3080 fndecl
= gfor_fndecl_select_string
;
3081 else if (code
->expr1
->ts
.kind
== 4)
3082 fndecl
= gfor_fndecl_select_string_char4
;
3086 tmp
= build_call_expr_loc (input_location
,
3088 build_int_cst (gfc_charlen_type_node
, n
),
3089 expr1se
.expr
, expr1se
.string_length
);
3090 case_num
= gfc_create_var (integer_type_node
, "case_num");
3091 gfc_add_modify (&block
, case_num
, tmp
);
3093 gfc_add_block_to_block (&block
, &expr1se
.post
);
3095 tmp
= gfc_finish_block (&body
);
3096 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3097 case_num
, tmp
, NULL_TREE
);
3098 gfc_add_expr_to_block (&block
, tmp
);
3100 tmp
= build1_v (LABEL_EXPR
, end_label
);
3101 gfc_add_expr_to_block (&block
, tmp
);
3103 return gfc_finish_block (&block
);
3107 /* Translate the three variants of the SELECT CASE construct.
3109 SELECT CASEs with INTEGER case expressions can be translated to an
3110 equivalent GENERIC switch statement, and for LOGICAL case
3111 expressions we build one or two if-else compares.
3113 SELECT CASEs with CHARACTER case expressions are a whole different
3114 story, because they don't exist in GENERIC. So we sort them and
3115 do a binary search at runtime.
3117 Fortran has no BREAK statement, and it does not allow jumps from
3118 one case block to another. That makes things a lot easier for
3122 gfc_trans_select (gfc_code
* code
)
3128 gcc_assert (code
&& code
->expr1
);
3129 gfc_init_block (&block
);
3131 /* Build the exit label and hang it in. */
3132 exit_label
= gfc_build_label_decl (NULL_TREE
);
3133 code
->exit_label
= exit_label
;
3135 /* Empty SELECT constructs are legal. */
3136 if (code
->block
== NULL
)
3137 body
= build_empty_stmt (input_location
);
3139 /* Select the correct translation function. */
3141 switch (code
->expr1
->ts
.type
)
3144 body
= gfc_trans_logical_select (code
);
3148 body
= gfc_trans_integer_select (code
);
3152 body
= gfc_trans_character_select (code
);
3156 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3160 /* Build everything together. */
3161 gfc_add_expr_to_block (&block
, body
);
3162 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3164 return gfc_finish_block (&block
);
3168 gfc_trans_select_type (gfc_code
* code
)
3174 gcc_assert (code
&& code
->expr1
);
3175 gfc_init_block (&block
);
3177 /* Build the exit label and hang it in. */
3178 exit_label
= gfc_build_label_decl (NULL_TREE
);
3179 code
->exit_label
= exit_label
;
3181 /* Empty SELECT constructs are legal. */
3182 if (code
->block
== NULL
)
3183 body
= build_empty_stmt (input_location
);
3185 body
= gfc_trans_select_type_cases (code
);
3187 /* Build everything together. */
3188 gfc_add_expr_to_block (&block
, body
);
3190 if (TREE_USED (exit_label
))
3191 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3193 return gfc_finish_block (&block
);
3197 /* Traversal function to substitute a replacement symtree if the symbol
3198 in the expression is the same as that passed. f == 2 signals that
3199 that variable itself is not to be checked - only the references.
3200 This group of functions is used when the variable expression in a
3201 FORALL assignment has internal references. For example:
3202 FORALL (i = 1:4) p(p(i)) = i
3203 The only recourse here is to store a copy of 'p' for the index
3206 static gfc_symtree
*new_symtree
;
3207 static gfc_symtree
*old_symtree
;
3210 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3212 if (expr
->expr_type
!= EXPR_VARIABLE
)
3217 else if (expr
->symtree
->n
.sym
== sym
)
3218 expr
->symtree
= new_symtree
;
3224 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3226 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3230 forall_restore (gfc_expr
*expr
,
3231 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3232 int *f ATTRIBUTE_UNUSED
)
3234 if (expr
->expr_type
!= EXPR_VARIABLE
)
3237 if (expr
->symtree
== new_symtree
)
3238 expr
->symtree
= old_symtree
;
3244 forall_restore_symtree (gfc_expr
*e
)
3246 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3250 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3255 gfc_symbol
*new_sym
;
3256 gfc_symbol
*old_sym
;
3260 /* Build a copy of the lvalue. */
3261 old_symtree
= c
->expr1
->symtree
;
3262 old_sym
= old_symtree
->n
.sym
;
3263 e
= gfc_lval_expr_from_sym (old_sym
);
3264 if (old_sym
->attr
.dimension
)
3266 gfc_init_se (&tse
, NULL
);
3267 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3268 gfc_add_block_to_block (pre
, &tse
.pre
);
3269 gfc_add_block_to_block (post
, &tse
.post
);
3270 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3272 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3274 /* Use the variable offset for the temporary. */
3275 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3276 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3281 gfc_init_se (&tse
, NULL
);
3282 gfc_init_se (&rse
, NULL
);
3283 gfc_conv_expr (&rse
, e
);
3284 if (e
->ts
.type
== BT_CHARACTER
)
3286 tse
.string_length
= rse
.string_length
;
3287 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3289 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3291 gfc_add_block_to_block (pre
, &tse
.pre
);
3292 gfc_add_block_to_block (post
, &tse
.post
);
3296 tmp
= gfc_typenode_for_spec (&e
->ts
);
3297 tse
.expr
= gfc_create_var (tmp
, "temp");
3300 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3301 e
->expr_type
== EXPR_VARIABLE
, false);
3302 gfc_add_expr_to_block (pre
, tmp
);
3306 /* Create a new symbol to represent the lvalue. */
3307 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3308 new_sym
->ts
= old_sym
->ts
;
3309 new_sym
->attr
.referenced
= 1;
3310 new_sym
->attr
.temporary
= 1;
3311 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3312 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3314 /* Use the temporary as the backend_decl. */
3315 new_sym
->backend_decl
= tse
.expr
;
3317 /* Create a fake symtree for it. */
3319 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3320 new_symtree
->n
.sym
= new_sym
;
3321 gcc_assert (new_symtree
== root
);
3323 /* Go through the expression reference replacing the old_symtree
3325 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3327 /* Now we have made this temporary, we might as well use it for
3328 the right hand side. */
3329 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3333 /* Handles dependencies in forall assignments. */
3335 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3342 lsym
= c
->expr1
->symtree
->n
.sym
;
3343 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3345 /* Now check for dependencies within the 'variable'
3346 expression itself. These are treated by making a complete
3347 copy of variable and changing all the references to it
3348 point to the copy instead. Note that the shallow copy of
3349 the variable will not suffice for derived types with
3350 pointer components. We therefore leave these to their
3352 if (lsym
->ts
.type
== BT_DERIVED
3353 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3357 if (find_forall_index (c
->expr1
, lsym
, 2))
3359 forall_make_variable_temp (c
, pre
, post
);
3363 /* Substrings with dependencies are treated in the same
3365 if (c
->expr1
->ts
.type
== BT_CHARACTER
3367 && c
->expr2
->expr_type
== EXPR_VARIABLE
3368 && lsym
== c
->expr2
->symtree
->n
.sym
)
3370 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3371 if (lref
->type
== REF_SUBSTRING
)
3373 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3374 if (rref
->type
== REF_SUBSTRING
)
3378 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3380 forall_make_variable_temp (c
, pre
, post
);
3389 cleanup_forall_symtrees (gfc_code
*c
)
3391 forall_restore_symtree (c
->expr1
);
3392 forall_restore_symtree (c
->expr2
);
3393 free (new_symtree
->n
.sym
);
3398 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3399 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3400 indicates whether we should generate code to test the FORALLs mask
3401 array. OUTER is the loop header to be used for initializing mask
3404 The generated loop format is:
3405 count = (end - start + step) / step
3418 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3419 int mask_flag
, stmtblock_t
*outer
)
3427 tree var
, start
, end
, step
;
3430 /* Initialize the mask index outside the FORALL nest. */
3431 if (mask_flag
&& forall_tmp
->mask
)
3432 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3434 iter
= forall_tmp
->this_loop
;
3435 nvar
= forall_tmp
->nvar
;
3436 for (n
= 0; n
< nvar
; n
++)
3439 start
= iter
->start
;
3443 exit_label
= gfc_build_label_decl (NULL_TREE
);
3444 TREE_USED (exit_label
) = 1;
3446 /* The loop counter. */
3447 count
= gfc_create_var (TREE_TYPE (var
), "count");
3449 /* The body of the loop. */
3450 gfc_init_block (&block
);
3452 /* The exit condition. */
3453 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3454 count
, build_int_cst (TREE_TYPE (count
), 0));
3455 if (forall_tmp
->do_concurrent
)
3456 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3457 build_int_cst (integer_type_node
,
3458 annot_expr_ivdep_kind
));
3460 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3461 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3462 cond
, tmp
, build_empty_stmt (input_location
));
3463 gfc_add_expr_to_block (&block
, tmp
);
3465 /* The main loop body. */
3466 gfc_add_expr_to_block (&block
, body
);
3468 /* Increment the loop variable. */
3469 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3471 gfc_add_modify (&block
, var
, tmp
);
3473 /* Advance to the next mask element. Only do this for the
3475 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3477 tree maskindex
= forall_tmp
->maskindex
;
3478 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3479 maskindex
, gfc_index_one_node
);
3480 gfc_add_modify (&block
, maskindex
, tmp
);
3483 /* Decrement the loop counter. */
3484 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3485 build_int_cst (TREE_TYPE (var
), 1));
3486 gfc_add_modify (&block
, count
, tmp
);
3488 body
= gfc_finish_block (&block
);
3490 /* Loop var initialization. */
3491 gfc_init_block (&block
);
3492 gfc_add_modify (&block
, var
, start
);
3495 /* Initialize the loop counter. */
3496 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3498 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3500 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3502 gfc_add_modify (&block
, count
, tmp
);
3504 /* The loop expression. */
3505 tmp
= build1_v (LOOP_EXPR
, body
);
3506 gfc_add_expr_to_block (&block
, tmp
);
3508 /* The exit label. */
3509 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3510 gfc_add_expr_to_block (&block
, tmp
);
3512 body
= gfc_finish_block (&block
);
3519 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3520 is nonzero, the body is controlled by all masks in the forall nest.
3521 Otherwise, the innermost loop is not controlled by it's mask. This
3522 is used for initializing that mask. */
3525 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3530 forall_info
*forall_tmp
;
3531 tree mask
, maskindex
;
3533 gfc_start_block (&header
);
3535 forall_tmp
= nested_forall_info
;
3536 while (forall_tmp
!= NULL
)
3538 /* Generate body with masks' control. */
3541 mask
= forall_tmp
->mask
;
3542 maskindex
= forall_tmp
->maskindex
;
3544 /* If a mask was specified make the assignment conditional. */
3547 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3548 body
= build3_v (COND_EXPR
, tmp
, body
,
3549 build_empty_stmt (input_location
));
3552 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3553 forall_tmp
= forall_tmp
->prev_nest
;
3557 gfc_add_expr_to_block (&header
, body
);
3558 return gfc_finish_block (&header
);
3562 /* Allocate data for holding a temporary array. Returns either a local
3563 temporary array or a pointer variable. */
3566 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3573 if (INTEGER_CST_P (size
))
3574 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3575 size
, gfc_index_one_node
);
3579 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3580 type
= build_array_type (elem_type
, type
);
3581 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3583 tmpvar
= gfc_create_var (type
, "temp");
3588 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3589 *pdata
= convert (pvoid_type_node
, tmpvar
);
3591 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3592 gfc_add_modify (pblock
, tmpvar
, tmp
);
3598 /* Generate codes to copy the temporary to the actual lhs. */
3601 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3603 gfc_ss
*lss
, gfc_ss
*rss
,
3604 tree wheremask
, bool invert
)
3606 stmtblock_t block
, body1
;
3613 (void) rss
; /* TODO: unused. */
3615 gfc_start_block (&block
);
3617 gfc_init_se (&rse
, NULL
);
3618 gfc_init_se (&lse
, NULL
);
3620 if (lss
== gfc_ss_terminator
)
3622 gfc_init_block (&body1
);
3623 gfc_conv_expr (&lse
, expr
);
3624 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3628 /* Initialize the loop. */
3629 gfc_init_loopinfo (&loop
);
3631 /* We may need LSS to determine the shape of the expression. */
3632 gfc_add_ss_to_loop (&loop
, lss
);
3634 gfc_conv_ss_startstride (&loop
);
3635 gfc_conv_loop_setup (&loop
, &expr
->where
);
3637 gfc_mark_ss_chain_used (lss
, 1);
3638 /* Start the loop body. */
3639 gfc_start_scalarized_body (&loop
, &body1
);
3641 /* Translate the expression. */
3642 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3644 gfc_conv_expr (&lse
, expr
);
3646 /* Form the expression of the temporary. */
3647 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3650 /* Use the scalar assignment. */
3651 rse
.string_length
= lse
.string_length
;
3652 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
3653 expr
->expr_type
== EXPR_VARIABLE
, false);
3655 /* Form the mask expression according to the mask tree list. */
3658 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3660 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3661 TREE_TYPE (wheremaskexpr
),
3663 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3665 build_empty_stmt (input_location
));
3668 gfc_add_expr_to_block (&body1
, tmp
);
3670 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3671 count1
, gfc_index_one_node
);
3672 gfc_add_modify (&body1
, count1
, tmp
);
3674 if (lss
== gfc_ss_terminator
)
3675 gfc_add_block_to_block (&block
, &body1
);
3678 /* Increment count3. */
3681 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3682 gfc_array_index_type
,
3683 count3
, gfc_index_one_node
);
3684 gfc_add_modify (&body1
, count3
, tmp
);
3687 /* Generate the copying loops. */
3688 gfc_trans_scalarizing_loops (&loop
, &body1
);
3690 gfc_add_block_to_block (&block
, &loop
.pre
);
3691 gfc_add_block_to_block (&block
, &loop
.post
);
3693 gfc_cleanup_loop (&loop
);
3694 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3695 as tree nodes in SS may not be valid in different scope. */
3698 tmp
= gfc_finish_block (&block
);
3703 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3704 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3705 and should not be freed. WHEREMASK is the conditional execution mask
3706 whose sense may be inverted by INVERT. */
3709 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3710 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3711 tree wheremask
, bool invert
)
3713 stmtblock_t block
, body1
;
3720 gfc_start_block (&block
);
3722 gfc_init_se (&rse
, NULL
);
3723 gfc_init_se (&lse
, NULL
);
3725 if (lss
== gfc_ss_terminator
)
3727 gfc_init_block (&body1
);
3728 gfc_conv_expr (&rse
, expr2
);
3729 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3733 /* Initialize the loop. */
3734 gfc_init_loopinfo (&loop
);
3736 /* We may need LSS to determine the shape of the expression. */
3737 gfc_add_ss_to_loop (&loop
, lss
);
3738 gfc_add_ss_to_loop (&loop
, rss
);
3740 gfc_conv_ss_startstride (&loop
);
3741 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3743 gfc_mark_ss_chain_used (rss
, 1);
3744 /* Start the loop body. */
3745 gfc_start_scalarized_body (&loop
, &body1
);
3747 /* Translate the expression. */
3748 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3750 gfc_conv_expr (&rse
, expr2
);
3752 /* Form the expression of the temporary. */
3753 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3756 /* Use the scalar assignment. */
3757 lse
.string_length
= rse
.string_length
;
3758 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3759 expr2
->expr_type
== EXPR_VARIABLE
, false);
3761 /* Form the mask expression according to the mask tree list. */
3764 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3766 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3767 TREE_TYPE (wheremaskexpr
),
3769 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3771 build_empty_stmt (input_location
));
3774 gfc_add_expr_to_block (&body1
, tmp
);
3776 if (lss
== gfc_ss_terminator
)
3778 gfc_add_block_to_block (&block
, &body1
);
3780 /* Increment count1. */
3781 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3782 count1
, gfc_index_one_node
);
3783 gfc_add_modify (&block
, count1
, tmp
);
3787 /* Increment count1. */
3788 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3789 count1
, gfc_index_one_node
);
3790 gfc_add_modify (&body1
, count1
, tmp
);
3792 /* Increment count3. */
3795 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3796 gfc_array_index_type
,
3797 count3
, gfc_index_one_node
);
3798 gfc_add_modify (&body1
, count3
, tmp
);
3801 /* Generate the copying loops. */
3802 gfc_trans_scalarizing_loops (&loop
, &body1
);
3804 gfc_add_block_to_block (&block
, &loop
.pre
);
3805 gfc_add_block_to_block (&block
, &loop
.post
);
3807 gfc_cleanup_loop (&loop
);
3808 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3809 as tree nodes in SS may not be valid in different scope. */
3812 tmp
= gfc_finish_block (&block
);
3817 /* Calculate the size of temporary needed in the assignment inside forall.
3818 LSS and RSS are filled in this function. */
3821 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3822 stmtblock_t
* pblock
,
3823 gfc_ss
**lss
, gfc_ss
**rss
)
3831 *lss
= gfc_walk_expr (expr1
);
3834 size
= gfc_index_one_node
;
3835 if (*lss
!= gfc_ss_terminator
)
3837 gfc_init_loopinfo (&loop
);
3839 /* Walk the RHS of the expression. */
3840 *rss
= gfc_walk_expr (expr2
);
3841 if (*rss
== gfc_ss_terminator
)
3842 /* The rhs is scalar. Add a ss for the expression. */
3843 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3845 /* Associate the SS with the loop. */
3846 gfc_add_ss_to_loop (&loop
, *lss
);
3847 /* We don't actually need to add the rhs at this point, but it might
3848 make guessing the loop bounds a bit easier. */
3849 gfc_add_ss_to_loop (&loop
, *rss
);
3851 /* We only want the shape of the expression, not rest of the junk
3852 generated by the scalarizer. */
3853 loop
.array_parameter
= 1;
3855 /* Calculate the bounds of the scalarization. */
3856 save_flag
= gfc_option
.rtcheck
;
3857 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3858 gfc_conv_ss_startstride (&loop
);
3859 gfc_option
.rtcheck
= save_flag
;
3860 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3862 /* Figure out how many elements we need. */
3863 for (i
= 0; i
< loop
.dimen
; i
++)
3865 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3866 gfc_array_index_type
,
3867 gfc_index_one_node
, loop
.from
[i
]);
3868 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3869 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3870 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3871 gfc_array_index_type
, size
, tmp
);
3873 gfc_add_block_to_block (pblock
, &loop
.pre
);
3874 size
= gfc_evaluate_now (size
, pblock
);
3875 gfc_add_block_to_block (pblock
, &loop
.post
);
3877 /* TODO: write a function that cleans up a loopinfo without freeing
3878 the SS chains. Currently a NOP. */
3885 /* Calculate the overall iterator number of the nested forall construct.
3886 This routine actually calculates the number of times the body of the
3887 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3888 that by the expression INNER_SIZE. The BLOCK argument specifies the
3889 block in which to calculate the result, and the optional INNER_SIZE_BODY
3890 argument contains any statements that need to executed (inside the loop)
3891 to initialize or calculate INNER_SIZE. */
3894 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3895 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3897 forall_info
*forall_tmp
= nested_forall_info
;
3901 /* We can eliminate the innermost unconditional loops with constant
3903 if (INTEGER_CST_P (inner_size
))
3906 && !forall_tmp
->mask
3907 && INTEGER_CST_P (forall_tmp
->size
))
3909 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3910 gfc_array_index_type
,
3911 inner_size
, forall_tmp
->size
);
3912 forall_tmp
= forall_tmp
->prev_nest
;
3915 /* If there are no loops left, we have our constant result. */
3920 /* Otherwise, create a temporary variable to compute the result. */
3921 number
= gfc_create_var (gfc_array_index_type
, "num");
3922 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3924 gfc_start_block (&body
);
3925 if (inner_size_body
)
3926 gfc_add_block_to_block (&body
, inner_size_body
);
3928 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3929 gfc_array_index_type
, number
, inner_size
);
3932 gfc_add_modify (&body
, number
, tmp
);
3933 tmp
= gfc_finish_block (&body
);
3935 /* Generate loops. */
3936 if (forall_tmp
!= NULL
)
3937 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3939 gfc_add_expr_to_block (block
, tmp
);
3945 /* Allocate temporary for forall construct. SIZE is the size of temporary
3946 needed. PTEMP1 is returned for space free. */
3949 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3956 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3957 if (!integer_onep (unit
))
3958 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3959 gfc_array_index_type
, size
, unit
);
3964 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3967 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3972 /* Allocate temporary for forall construct according to the information in
3973 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3974 assignment inside forall. PTEMP1 is returned for space free. */
3977 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3978 tree inner_size
, stmtblock_t
* inner_size_body
,
3979 stmtblock_t
* block
, tree
* ptemp1
)
3983 /* Calculate the total size of temporary needed in forall construct. */
3984 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3985 inner_size_body
, block
);
3987 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3991 /* Handle assignments inside forall which need temporary.
3993 forall (i=start:end:stride; maskexpr)
3996 (where e,f<i> are arbitrary expressions possibly involving i
3997 and there is a dependency between e<i> and f<i>)
3999 masktmp(:) = maskexpr(:)
4004 for (i = start; i <= end; i += stride)
4008 for (i = start; i <= end; i += stride)
4010 if (masktmp[maskindex++])
4011 tmp[count1++] = f<i>
4015 for (i = start; i <= end; i += stride)
4017 if (masktmp[maskindex++])
4018 e<i> = tmp[count1++]
4023 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4024 tree wheremask
, bool invert
,
4025 forall_info
* nested_forall_info
,
4026 stmtblock_t
* block
)
4034 stmtblock_t inner_size_body
;
4036 /* Create vars. count1 is the current iterator number of the nested
4038 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4040 /* Count is the wheremask index. */
4043 count
= gfc_create_var (gfc_array_index_type
, "count");
4044 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4049 /* Initialize count1. */
4050 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4052 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4053 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4054 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4055 if (expr1
->ts
.type
== BT_CHARACTER
)
4058 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
4061 gfc_init_se (&ssse
, NULL
);
4062 gfc_conv_expr (&ssse
, expr1
);
4063 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4064 ssse
.string_length
);
4068 if (!expr1
->ts
.u
.cl
->backend_decl
)
4071 gcc_assert (expr1
->ts
.u
.cl
->length
);
4072 gfc_init_se (&tse
, NULL
);
4073 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4074 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4076 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4077 expr1
->ts
.u
.cl
->backend_decl
);
4081 type
= gfc_typenode_for_spec (&expr1
->ts
);
4083 gfc_init_block (&inner_size_body
);
4084 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4087 /* Allocate temporary for nested forall construct according to the
4088 information in nested_forall_info and inner_size. */
4089 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4090 &inner_size_body
, block
, &ptemp1
);
4092 /* Generate codes to copy rhs to the temporary . */
4093 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4096 /* Generate body and loops according to the information in
4097 nested_forall_info. */
4098 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4099 gfc_add_expr_to_block (block
, tmp
);
4102 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4106 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4108 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4109 rss; there must be a better way. */
4110 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4113 /* Generate codes to copy the temporary to lhs. */
4114 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4118 /* Generate body and loops according to the information in
4119 nested_forall_info. */
4120 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4121 gfc_add_expr_to_block (block
, tmp
);
4125 /* Free the temporary. */
4126 tmp
= gfc_call_free (ptemp1
);
4127 gfc_add_expr_to_block (block
, tmp
);
4132 /* Translate pointer assignment inside FORALL which need temporary. */
4135 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4136 forall_info
* nested_forall_info
,
4137 stmtblock_t
* block
)
4144 gfc_array_info
*info
;
4151 tree tmp
, tmp1
, ptemp1
;
4153 count
= gfc_create_var (gfc_array_index_type
, "count");
4154 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4156 inner_size
= gfc_index_one_node
;
4157 lss
= gfc_walk_expr (expr1
);
4158 rss
= gfc_walk_expr (expr2
);
4159 if (lss
== gfc_ss_terminator
)
4161 type
= gfc_typenode_for_spec (&expr1
->ts
);
4162 type
= build_pointer_type (type
);
4164 /* Allocate temporary for nested forall construct according to the
4165 information in nested_forall_info and inner_size. */
4166 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4167 inner_size
, NULL
, block
, &ptemp1
);
4168 gfc_start_block (&body
);
4169 gfc_init_se (&lse
, NULL
);
4170 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4171 gfc_init_se (&rse
, NULL
);
4172 rse
.want_pointer
= 1;
4173 gfc_conv_expr (&rse
, expr2
);
4174 gfc_add_block_to_block (&body
, &rse
.pre
);
4175 gfc_add_modify (&body
, lse
.expr
,
4176 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4177 gfc_add_block_to_block (&body
, &rse
.post
);
4179 /* Increment count. */
4180 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4181 count
, gfc_index_one_node
);
4182 gfc_add_modify (&body
, count
, tmp
);
4184 tmp
= gfc_finish_block (&body
);
4186 /* Generate body and loops according to the information in
4187 nested_forall_info. */
4188 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4189 gfc_add_expr_to_block (block
, tmp
);
4192 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4194 gfc_start_block (&body
);
4195 gfc_init_se (&lse
, NULL
);
4196 gfc_init_se (&rse
, NULL
);
4197 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4198 lse
.want_pointer
= 1;
4199 gfc_conv_expr (&lse
, expr1
);
4200 gfc_add_block_to_block (&body
, &lse
.pre
);
4201 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4202 gfc_add_block_to_block (&body
, &lse
.post
);
4203 /* Increment count. */
4204 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4205 count
, gfc_index_one_node
);
4206 gfc_add_modify (&body
, count
, tmp
);
4207 tmp
= gfc_finish_block (&body
);
4209 /* Generate body and loops according to the information in
4210 nested_forall_info. */
4211 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4212 gfc_add_expr_to_block (block
, tmp
);
4216 gfc_init_loopinfo (&loop
);
4218 /* Associate the SS with the loop. */
4219 gfc_add_ss_to_loop (&loop
, rss
);
4221 /* Setup the scalarizing loops and bounds. */
4222 gfc_conv_ss_startstride (&loop
);
4224 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4226 info
= &rss
->info
->data
.array
;
4227 desc
= info
->descriptor
;
4229 /* Make a new descriptor. */
4230 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4231 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4232 loop
.from
, loop
.to
, 1,
4233 GFC_ARRAY_UNKNOWN
, true);
4235 /* Allocate temporary for nested forall construct. */
4236 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4237 inner_size
, NULL
, block
, &ptemp1
);
4238 gfc_start_block (&body
);
4239 gfc_init_se (&lse
, NULL
);
4240 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4241 lse
.direct_byref
= 1;
4242 gfc_conv_expr_descriptor (&lse
, expr2
);
4244 gfc_add_block_to_block (&body
, &lse
.pre
);
4245 gfc_add_block_to_block (&body
, &lse
.post
);
4247 /* Increment count. */
4248 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4249 count
, gfc_index_one_node
);
4250 gfc_add_modify (&body
, count
, tmp
);
4252 tmp
= gfc_finish_block (&body
);
4254 /* Generate body and loops according to the information in
4255 nested_forall_info. */
4256 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4257 gfc_add_expr_to_block (block
, tmp
);
4260 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4262 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4263 gfc_init_se (&lse
, NULL
);
4264 gfc_conv_expr_descriptor (&lse
, expr1
);
4265 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4266 gfc_start_block (&body
);
4267 gfc_add_block_to_block (&body
, &lse
.pre
);
4268 gfc_add_block_to_block (&body
, &lse
.post
);
4270 /* Increment count. */
4271 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4272 count
, gfc_index_one_node
);
4273 gfc_add_modify (&body
, count
, tmp
);
4275 tmp
= gfc_finish_block (&body
);
4277 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4278 gfc_add_expr_to_block (block
, tmp
);
4280 /* Free the temporary. */
4283 tmp
= gfc_call_free (ptemp1
);
4284 gfc_add_expr_to_block (block
, tmp
);
4289 /* FORALL and WHERE statements are really nasty, especially when you nest
4290 them. All the rhs of a forall assignment must be evaluated before the
4291 actual assignments are performed. Presumably this also applies to all the
4292 assignments in an inner where statement. */
4294 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4295 linear array, relying on the fact that we process in the same order in all
4298 forall (i=start:end:stride; maskexpr)
4302 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4304 count = ((end + 1 - start) / stride)
4305 masktmp(:) = maskexpr(:)
4308 for (i = start; i <= end; i += stride)
4310 if (masktmp[maskindex++])
4314 for (i = start; i <= end; i += stride)
4316 if (masktmp[maskindex++])
4320 Note that this code only works when there are no dependencies.
4321 Forall loop with array assignments and data dependencies are a real pain,
4322 because the size of the temporary cannot always be determined before the
4323 loop is executed. This problem is compounded by the presence of nested
4328 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4345 tree cycle_label
= NULL_TREE
;
4349 gfc_forall_iterator
*fa
;
4352 gfc_saved_var
*saved_vars
;
4353 iter_info
*this_forall
;
4357 /* Do nothing if the mask is false. */
4359 && code
->expr1
->expr_type
== EXPR_CONSTANT
4360 && !code
->expr1
->value
.logical
)
4361 return build_empty_stmt (input_location
);
4364 /* Count the FORALL index number. */
4365 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4369 /* Allocate the space for var, start, end, step, varexpr. */
4370 var
= XCNEWVEC (tree
, nvar
);
4371 start
= XCNEWVEC (tree
, nvar
);
4372 end
= XCNEWVEC (tree
, nvar
);
4373 step
= XCNEWVEC (tree
, nvar
);
4374 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4375 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4377 /* Allocate the space for info. */
4378 info
= XCNEW (forall_info
);
4380 gfc_start_block (&pre
);
4381 gfc_init_block (&post
);
4382 gfc_init_block (&block
);
4385 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4387 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4389 /* Allocate space for this_forall. */
4390 this_forall
= XCNEW (iter_info
);
4392 /* Create a temporary variable for the FORALL index. */
4393 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4394 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4395 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4397 /* Record it in this_forall. */
4398 this_forall
->var
= var
[n
];
4400 /* Replace the index symbol's backend_decl with the temporary decl. */
4401 sym
->backend_decl
= var
[n
];
4403 /* Work out the start, end and stride for the loop. */
4404 gfc_init_se (&se
, NULL
);
4405 gfc_conv_expr_val (&se
, fa
->start
);
4406 /* Record it in this_forall. */
4407 this_forall
->start
= se
.expr
;
4408 gfc_add_block_to_block (&block
, &se
.pre
);
4411 gfc_init_se (&se
, NULL
);
4412 gfc_conv_expr_val (&se
, fa
->end
);
4413 /* Record it in this_forall. */
4414 this_forall
->end
= se
.expr
;
4415 gfc_make_safe_expr (&se
);
4416 gfc_add_block_to_block (&block
, &se
.pre
);
4419 gfc_init_se (&se
, NULL
);
4420 gfc_conv_expr_val (&se
, fa
->stride
);
4421 /* Record it in this_forall. */
4422 this_forall
->step
= se
.expr
;
4423 gfc_make_safe_expr (&se
);
4424 gfc_add_block_to_block (&block
, &se
.pre
);
4427 /* Set the NEXT field of this_forall to NULL. */
4428 this_forall
->next
= NULL
;
4429 /* Link this_forall to the info construct. */
4430 if (info
->this_loop
)
4432 iter_info
*iter_tmp
= info
->this_loop
;
4433 while (iter_tmp
->next
!= NULL
)
4434 iter_tmp
= iter_tmp
->next
;
4435 iter_tmp
->next
= this_forall
;
4438 info
->this_loop
= this_forall
;
4444 /* Calculate the size needed for the current forall level. */
4445 size
= gfc_index_one_node
;
4446 for (n
= 0; n
< nvar
; n
++)
4448 /* size = (end + step - start) / step. */
4449 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4451 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4453 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4455 tmp
= convert (gfc_array_index_type
, tmp
);
4457 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4461 /* Record the nvar and size of current forall level. */
4467 /* If the mask is .true., consider the FORALL unconditional. */
4468 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4469 && code
->expr1
->value
.logical
)
4477 /* First we need to allocate the mask. */
4480 /* As the mask array can be very big, prefer compact boolean types. */
4481 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4482 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4483 size
, NULL
, &block
, &pmask
);
4484 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4486 /* Record them in the info structure. */
4487 info
->maskindex
= maskindex
;
4492 /* No mask was specified. */
4493 maskindex
= NULL_TREE
;
4494 mask
= pmask
= NULL_TREE
;
4497 /* Link the current forall level to nested_forall_info. */
4498 info
->prev_nest
= nested_forall_info
;
4499 nested_forall_info
= info
;
4501 /* Copy the mask into a temporary variable if required.
4502 For now we assume a mask temporary is needed. */
4505 /* As the mask array can be very big, prefer compact boolean types. */
4506 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4508 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4510 /* Start of mask assignment loop body. */
4511 gfc_start_block (&body
);
4513 /* Evaluate the mask expression. */
4514 gfc_init_se (&se
, NULL
);
4515 gfc_conv_expr_val (&se
, code
->expr1
);
4516 gfc_add_block_to_block (&body
, &se
.pre
);
4518 /* Store the mask. */
4519 se
.expr
= convert (mask_type
, se
.expr
);
4521 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4522 gfc_add_modify (&body
, tmp
, se
.expr
);
4524 /* Advance to the next mask element. */
4525 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4526 maskindex
, gfc_index_one_node
);
4527 gfc_add_modify (&body
, maskindex
, tmp
);
4529 /* Generate the loops. */
4530 tmp
= gfc_finish_block (&body
);
4531 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4532 gfc_add_expr_to_block (&block
, tmp
);
4535 if (code
->op
== EXEC_DO_CONCURRENT
)
4537 gfc_init_block (&body
);
4538 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4539 code
->cycle_label
= cycle_label
;
4540 tmp
= gfc_trans_code (code
->block
->next
);
4541 gfc_add_expr_to_block (&body
, tmp
);
4543 if (TREE_USED (cycle_label
))
4545 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4546 gfc_add_expr_to_block (&body
, tmp
);
4549 tmp
= gfc_finish_block (&body
);
4550 nested_forall_info
->do_concurrent
= true;
4551 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4552 gfc_add_expr_to_block (&block
, tmp
);
4556 c
= code
->block
->next
;
4558 /* TODO: loop merging in FORALL statements. */
4559 /* Now that we've got a copy of the mask, generate the assignment loops. */
4565 /* A scalar or array assignment. DO the simple check for
4566 lhs to rhs dependencies. These make a temporary for the
4567 rhs and form a second forall block to copy to variable. */
4568 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4570 /* Temporaries due to array assignment data dependencies introduce
4571 no end of problems. */
4572 if (need_temp
|| flag_test_forall_temp
)
4573 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4574 nested_forall_info
, &block
);
4577 /* Use the normal assignment copying routines. */
4578 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4580 /* Generate body and loops. */
4581 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4583 gfc_add_expr_to_block (&block
, tmp
);
4586 /* Cleanup any temporary symtrees that have been made to deal
4587 with dependencies. */
4589 cleanup_forall_symtrees (c
);
4594 /* Translate WHERE or WHERE construct nested in FORALL. */
4595 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4598 /* Pointer assignment inside FORALL. */
4599 case EXEC_POINTER_ASSIGN
:
4600 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4601 /* Avoid cases where a temporary would never be needed and where
4602 the temp code is guaranteed to fail. */
4604 || (flag_test_forall_temp
4605 && c
->expr2
->expr_type
!= EXPR_CONSTANT
4606 && c
->expr2
->expr_type
!= EXPR_NULL
))
4607 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4608 nested_forall_info
, &block
);
4611 /* Use the normal assignment copying routines. */
4612 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4614 /* Generate body and loops. */
4615 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4617 gfc_add_expr_to_block (&block
, tmp
);
4622 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4623 gfc_add_expr_to_block (&block
, tmp
);
4626 /* Explicit subroutine calls are prevented by the frontend but interface
4627 assignments can legitimately produce them. */
4628 case EXEC_ASSIGN_CALL
:
4629 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4630 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4631 gfc_add_expr_to_block (&block
, tmp
);
4642 /* Restore the original index variables. */
4643 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4644 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4646 /* Free the space for var, start, end, step, varexpr. */
4654 for (this_forall
= info
->this_loop
; this_forall
;)
4656 iter_info
*next
= this_forall
->next
;
4661 /* Free the space for this forall_info. */
4666 /* Free the temporary for the mask. */
4667 tmp
= gfc_call_free (pmask
);
4668 gfc_add_expr_to_block (&block
, tmp
);
4671 pushdecl (maskindex
);
4673 gfc_add_block_to_block (&pre
, &block
);
4674 gfc_add_block_to_block (&pre
, &post
);
4676 return gfc_finish_block (&pre
);
4680 /* Translate the FORALL statement or construct. */
4682 tree
gfc_trans_forall (gfc_code
* code
)
4684 return gfc_trans_forall_1 (code
, NULL
);
4688 /* Translate the DO CONCURRENT construct. */
4690 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4692 return gfc_trans_forall_1 (code
, NULL
);
4696 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4697 If the WHERE construct is nested in FORALL, compute the overall temporary
4698 needed by the WHERE mask expression multiplied by the iterator number of
4700 ME is the WHERE mask expression.
4701 MASK is the current execution mask upon input, whose sense may or may
4702 not be inverted as specified by the INVERT argument.
4703 CMASK is the updated execution mask on output, or NULL if not required.
4704 PMASK is the pending execution mask on output, or NULL if not required.
4705 BLOCK is the block in which to place the condition evaluation loops. */
4708 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4709 tree mask
, bool invert
, tree cmask
, tree pmask
,
4710 tree mask_type
, stmtblock_t
* block
)
4715 stmtblock_t body
, body1
;
4716 tree count
, cond
, mtmp
;
4719 gfc_init_loopinfo (&loop
);
4721 lss
= gfc_walk_expr (me
);
4722 rss
= gfc_walk_expr (me
);
4724 /* Variable to index the temporary. */
4725 count
= gfc_create_var (gfc_array_index_type
, "count");
4726 /* Initialize count. */
4727 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4729 gfc_start_block (&body
);
4731 gfc_init_se (&rse
, NULL
);
4732 gfc_init_se (&lse
, NULL
);
4734 if (lss
== gfc_ss_terminator
)
4736 gfc_init_block (&body1
);
4740 /* Initialize the loop. */
4741 gfc_init_loopinfo (&loop
);
4743 /* We may need LSS to determine the shape of the expression. */
4744 gfc_add_ss_to_loop (&loop
, lss
);
4745 gfc_add_ss_to_loop (&loop
, rss
);
4747 gfc_conv_ss_startstride (&loop
);
4748 gfc_conv_loop_setup (&loop
, &me
->where
);
4750 gfc_mark_ss_chain_used (rss
, 1);
4751 /* Start the loop body. */
4752 gfc_start_scalarized_body (&loop
, &body1
);
4754 /* Translate the expression. */
4755 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4757 gfc_conv_expr (&rse
, me
);
4760 /* Variable to evaluate mask condition. */
4761 cond
= gfc_create_var (mask_type
, "cond");
4762 if (mask
&& (cmask
|| pmask
))
4763 mtmp
= gfc_create_var (mask_type
, "mask");
4764 else mtmp
= NULL_TREE
;
4766 gfc_add_block_to_block (&body1
, &lse
.pre
);
4767 gfc_add_block_to_block (&body1
, &rse
.pre
);
4769 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4771 if (mask
&& (cmask
|| pmask
))
4773 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4775 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4776 gfc_add_modify (&body1
, mtmp
, tmp
);
4781 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4784 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4786 gfc_add_modify (&body1
, tmp1
, tmp
);
4791 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4792 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4794 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4796 gfc_add_modify (&body1
, tmp1
, tmp
);
4799 gfc_add_block_to_block (&body1
, &lse
.post
);
4800 gfc_add_block_to_block (&body1
, &rse
.post
);
4802 if (lss
== gfc_ss_terminator
)
4804 gfc_add_block_to_block (&body
, &body1
);
4808 /* Increment count. */
4809 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4810 count
, gfc_index_one_node
);
4811 gfc_add_modify (&body1
, count
, tmp1
);
4813 /* Generate the copying loops. */
4814 gfc_trans_scalarizing_loops (&loop
, &body1
);
4816 gfc_add_block_to_block (&body
, &loop
.pre
);
4817 gfc_add_block_to_block (&body
, &loop
.post
);
4819 gfc_cleanup_loop (&loop
);
4820 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4821 as tree nodes in SS may not be valid in different scope. */
4824 tmp1
= gfc_finish_block (&body
);
4825 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4826 if (nested_forall_info
!= NULL
)
4827 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4829 gfc_add_expr_to_block (block
, tmp1
);
4833 /* Translate an assignment statement in a WHERE statement or construct
4834 statement. The MASK expression is used to control which elements
4835 of EXPR1 shall be assigned. The sense of MASK is specified by
4839 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4840 tree mask
, bool invert
,
4841 tree count1
, tree count2
,
4847 gfc_ss
*lss_section
;
4854 tree index
, maskexpr
;
4856 /* A defined assignment. */
4857 if (cnext
&& cnext
->resolved_sym
)
4858 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4861 /* TODO: handle this special case.
4862 Special case a single function returning an array. */
4863 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4865 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4871 /* Assignment of the form lhs = rhs. */
4872 gfc_start_block (&block
);
4874 gfc_init_se (&lse
, NULL
);
4875 gfc_init_se (&rse
, NULL
);
4878 lss
= gfc_walk_expr (expr1
);
4881 /* In each where-assign-stmt, the mask-expr and the variable being
4882 defined shall be arrays of the same shape. */
4883 gcc_assert (lss
!= gfc_ss_terminator
);
4885 /* The assignment needs scalarization. */
4888 /* Find a non-scalar SS from the lhs. */
4889 while (lss_section
!= gfc_ss_terminator
4890 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4891 lss_section
= lss_section
->next
;
4893 gcc_assert (lss_section
!= gfc_ss_terminator
);
4895 /* Initialize the scalarizer. */
4896 gfc_init_loopinfo (&loop
);
4899 rss
= gfc_walk_expr (expr2
);
4900 if (rss
== gfc_ss_terminator
)
4902 /* The rhs is scalar. Add a ss for the expression. */
4903 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4904 rss
->info
->where
= 1;
4907 /* Associate the SS with the loop. */
4908 gfc_add_ss_to_loop (&loop
, lss
);
4909 gfc_add_ss_to_loop (&loop
, rss
);
4911 /* Calculate the bounds of the scalarization. */
4912 gfc_conv_ss_startstride (&loop
);
4914 /* Resolve any data dependencies in the statement. */
4915 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4917 /* Setup the scalarizing loops. */
4918 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4920 /* Setup the gfc_se structures. */
4921 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4922 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4925 gfc_mark_ss_chain_used (rss
, 1);
4926 if (loop
.temp_ss
== NULL
)
4929 gfc_mark_ss_chain_used (lss
, 1);
4933 lse
.ss
= loop
.temp_ss
;
4934 gfc_mark_ss_chain_used (lss
, 3);
4935 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4938 /* Start the scalarized loop body. */
4939 gfc_start_scalarized_body (&loop
, &body
);
4941 /* Translate the expression. */
4942 gfc_conv_expr (&rse
, expr2
);
4943 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4944 gfc_conv_tmp_array_ref (&lse
);
4946 gfc_conv_expr (&lse
, expr1
);
4948 /* Form the mask expression according to the mask. */
4950 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4952 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4953 TREE_TYPE (maskexpr
), maskexpr
);
4955 /* Use the scalar assignment as is. */
4956 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4957 false, loop
.temp_ss
== NULL
);
4959 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4961 gfc_add_expr_to_block (&body
, tmp
);
4963 if (lss
== gfc_ss_terminator
)
4965 /* Increment count1. */
4966 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4967 count1
, gfc_index_one_node
);
4968 gfc_add_modify (&body
, count1
, tmp
);
4970 /* Use the scalar assignment as is. */
4971 gfc_add_block_to_block (&block
, &body
);
4975 gcc_assert (lse
.ss
== gfc_ss_terminator
4976 && rse
.ss
== gfc_ss_terminator
);
4978 if (loop
.temp_ss
!= NULL
)
4980 /* Increment count1 before finish the main body of a scalarized
4982 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4983 gfc_array_index_type
, count1
, gfc_index_one_node
);
4984 gfc_add_modify (&body
, count1
, tmp
);
4985 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4987 /* We need to copy the temporary to the actual lhs. */
4988 gfc_init_se (&lse
, NULL
);
4989 gfc_init_se (&rse
, NULL
);
4990 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4991 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4993 rse
.ss
= loop
.temp_ss
;
4996 gfc_conv_tmp_array_ref (&rse
);
4997 gfc_conv_expr (&lse
, expr1
);
4999 gcc_assert (lse
.ss
== gfc_ss_terminator
5000 && rse
.ss
== gfc_ss_terminator
);
5002 /* Form the mask expression according to the mask tree list. */
5004 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5006 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5007 TREE_TYPE (maskexpr
), maskexpr
);
5009 /* Use the scalar assignment as is. */
5010 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
5011 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
5012 build_empty_stmt (input_location
));
5013 gfc_add_expr_to_block (&body
, tmp
);
5015 /* Increment count2. */
5016 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5017 gfc_array_index_type
, count2
,
5018 gfc_index_one_node
);
5019 gfc_add_modify (&body
, count2
, tmp
);
5023 /* Increment count1. */
5024 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5025 gfc_array_index_type
, count1
,
5026 gfc_index_one_node
);
5027 gfc_add_modify (&body
, count1
, tmp
);
5030 /* Generate the copying loops. */
5031 gfc_trans_scalarizing_loops (&loop
, &body
);
5033 /* Wrap the whole thing up. */
5034 gfc_add_block_to_block (&block
, &loop
.pre
);
5035 gfc_add_block_to_block (&block
, &loop
.post
);
5036 gfc_cleanup_loop (&loop
);
5039 return gfc_finish_block (&block
);
5043 /* Translate the WHERE construct or statement.
5044 This function can be called iteratively to translate the nested WHERE
5045 construct or statement.
5046 MASK is the control mask. */
5049 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
5050 forall_info
* nested_forall_info
, stmtblock_t
* block
)
5052 stmtblock_t inner_size_body
;
5053 tree inner_size
, size
;
5062 tree count1
, count2
;
5066 tree pcmask
= NULL_TREE
;
5067 tree ppmask
= NULL_TREE
;
5068 tree cmask
= NULL_TREE
;
5069 tree pmask
= NULL_TREE
;
5070 gfc_actual_arglist
*arg
;
5072 /* the WHERE statement or the WHERE construct statement. */
5073 cblock
= code
->block
;
5075 /* As the mask array can be very big, prefer compact boolean types. */
5076 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5078 /* Determine which temporary masks are needed. */
5081 /* One clause: No ELSEWHEREs. */
5082 need_cmask
= (cblock
->next
!= 0);
5085 else if (cblock
->block
->block
)
5087 /* Three or more clauses: Conditional ELSEWHEREs. */
5091 else if (cblock
->next
)
5093 /* Two clauses, the first non-empty. */
5095 need_pmask
= (mask
!= NULL_TREE
5096 && cblock
->block
->next
!= 0);
5098 else if (!cblock
->block
->next
)
5100 /* Two clauses, both empty. */
5104 /* Two clauses, the first empty, the second non-empty. */
5107 need_cmask
= (cblock
->block
->expr1
!= 0);
5116 if (need_cmask
|| need_pmask
)
5118 /* Calculate the size of temporary needed by the mask-expr. */
5119 gfc_init_block (&inner_size_body
);
5120 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5121 &inner_size_body
, &lss
, &rss
);
5123 gfc_free_ss_chain (lss
);
5124 gfc_free_ss_chain (rss
);
5126 /* Calculate the total size of temporary needed. */
5127 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5128 &inner_size_body
, block
);
5130 /* Check whether the size is negative. */
5131 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
5132 gfc_index_zero_node
);
5133 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5134 cond
, gfc_index_zero_node
, size
);
5135 size
= gfc_evaluate_now (size
, block
);
5137 /* Allocate temporary for WHERE mask if needed. */
5139 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5142 /* Allocate temporary for !mask if needed. */
5144 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5150 /* Each time around this loop, the where clause is conditional
5151 on the value of mask and invert, which are updated at the
5152 bottom of the loop. */
5154 /* Has mask-expr. */
5157 /* Ensure that the WHERE mask will be evaluated exactly once.
5158 If there are no statements in this WHERE/ELSEWHERE clause,
5159 then we don't need to update the control mask (cmask).
5160 If this is the last clause of the WHERE construct, then
5161 we don't need to update the pending control mask (pmask). */
5163 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5165 cblock
->next
? cmask
: NULL_TREE
,
5166 cblock
->block
? pmask
: NULL_TREE
,
5169 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5171 (cblock
->next
|| cblock
->block
)
5172 ? cmask
: NULL_TREE
,
5173 NULL_TREE
, mask_type
, block
);
5177 /* It's a final elsewhere-stmt. No mask-expr is present. */
5181 /* The body of this where clause are controlled by cmask with
5182 sense specified by invert. */
5184 /* Get the assignment statement of a WHERE statement, or the first
5185 statement in where-body-construct of a WHERE construct. */
5186 cnext
= cblock
->next
;
5191 /* WHERE assignment statement. */
5192 case EXEC_ASSIGN_CALL
:
5194 arg
= cnext
->ext
.actual
;
5195 expr1
= expr2
= NULL
;
5196 for (; arg
; arg
= arg
->next
)
5208 expr1
= cnext
->expr1
;
5209 expr2
= cnext
->expr2
;
5211 if (nested_forall_info
!= NULL
)
5213 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5214 if ((need_temp
|| flag_test_forall_temp
)
5215 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5216 gfc_trans_assign_need_temp (expr1
, expr2
,
5218 nested_forall_info
, block
);
5221 /* Variables to control maskexpr. */
5222 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5223 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5224 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5225 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5227 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5232 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5234 gfc_add_expr_to_block (block
, tmp
);
5239 /* Variables to control maskexpr. */
5240 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5241 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5242 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5243 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5245 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5249 gfc_add_expr_to_block (block
, tmp
);
5254 /* WHERE or WHERE construct is part of a where-body-construct. */
5256 gfc_trans_where_2 (cnext
, cmask
, invert
,
5257 nested_forall_info
, block
);
5264 /* The next statement within the same where-body-construct. */
5265 cnext
= cnext
->next
;
5267 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5268 cblock
= cblock
->block
;
5269 if (mask
== NULL_TREE
)
5271 /* If we're the initial WHERE, we can simply invert the sense
5272 of the current mask to obtain the "mask" for the remaining
5279 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5285 /* If we allocated a pending mask array, deallocate it now. */
5288 tmp
= gfc_call_free (ppmask
);
5289 gfc_add_expr_to_block (block
, tmp
);
5292 /* If we allocated a current mask array, deallocate it now. */
5295 tmp
= gfc_call_free (pcmask
);
5296 gfc_add_expr_to_block (block
, tmp
);
5300 /* Translate a simple WHERE construct or statement without dependencies.
5301 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5302 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5303 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5306 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5308 stmtblock_t block
, body
;
5309 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5310 tree tmp
, cexpr
, tstmt
, estmt
;
5311 gfc_ss
*css
, *tdss
, *tsss
;
5312 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5316 bool maybe_workshare
= false;
5318 /* Allow the scalarizer to workshare simple where loops. */
5319 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5320 == OMPWS_WORKSHARE_FLAG
)
5322 maybe_workshare
= true;
5323 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5326 cond
= cblock
->expr1
;
5327 tdst
= cblock
->next
->expr1
;
5328 tsrc
= cblock
->next
->expr2
;
5329 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5330 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5332 gfc_start_block (&block
);
5333 gfc_init_loopinfo (&loop
);
5335 /* Handle the condition. */
5336 gfc_init_se (&cse
, NULL
);
5337 css
= gfc_walk_expr (cond
);
5338 gfc_add_ss_to_loop (&loop
, css
);
5340 /* Handle the then-clause. */
5341 gfc_init_se (&tdse
, NULL
);
5342 gfc_init_se (&tsse
, NULL
);
5343 tdss
= gfc_walk_expr (tdst
);
5344 tsss
= gfc_walk_expr (tsrc
);
5345 if (tsss
== gfc_ss_terminator
)
5347 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5348 tsss
->info
->where
= 1;
5350 gfc_add_ss_to_loop (&loop
, tdss
);
5351 gfc_add_ss_to_loop (&loop
, tsss
);
5355 /* Handle the else clause. */
5356 gfc_init_se (&edse
, NULL
);
5357 gfc_init_se (&esse
, NULL
);
5358 edss
= gfc_walk_expr (edst
);
5359 esss
= gfc_walk_expr (esrc
);
5360 if (esss
== gfc_ss_terminator
)
5362 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5363 esss
->info
->where
= 1;
5365 gfc_add_ss_to_loop (&loop
, edss
);
5366 gfc_add_ss_to_loop (&loop
, esss
);
5369 gfc_conv_ss_startstride (&loop
);
5370 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5372 gfc_mark_ss_chain_used (css
, 1);
5373 gfc_mark_ss_chain_used (tdss
, 1);
5374 gfc_mark_ss_chain_used (tsss
, 1);
5377 gfc_mark_ss_chain_used (edss
, 1);
5378 gfc_mark_ss_chain_used (esss
, 1);
5381 gfc_start_scalarized_body (&loop
, &body
);
5383 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5384 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5385 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5391 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5392 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5397 gfc_conv_expr (&cse
, cond
);
5398 gfc_add_block_to_block (&body
, &cse
.pre
);
5401 gfc_conv_expr (&tsse
, tsrc
);
5402 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5403 gfc_conv_tmp_array_ref (&tdse
);
5405 gfc_conv_expr (&tdse
, tdst
);
5409 gfc_conv_expr (&esse
, esrc
);
5410 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5411 gfc_conv_tmp_array_ref (&edse
);
5413 gfc_conv_expr (&edse
, edst
);
5416 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5417 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5419 : build_empty_stmt (input_location
);
5420 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5421 gfc_add_expr_to_block (&body
, tmp
);
5422 gfc_add_block_to_block (&body
, &cse
.post
);
5424 if (maybe_workshare
)
5425 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5426 gfc_trans_scalarizing_loops (&loop
, &body
);
5427 gfc_add_block_to_block (&block
, &loop
.pre
);
5428 gfc_add_block_to_block (&block
, &loop
.post
);
5429 gfc_cleanup_loop (&loop
);
5431 return gfc_finish_block (&block
);
5434 /* As the WHERE or WHERE construct statement can be nested, we call
5435 gfc_trans_where_2 to do the translation, and pass the initial
5436 NULL values for both the control mask and the pending control mask. */
5439 gfc_trans_where (gfc_code
* code
)
5445 cblock
= code
->block
;
5447 && cblock
->next
->op
== EXEC_ASSIGN
5448 && !cblock
->next
->next
)
5450 eblock
= cblock
->block
;
5453 /* A simple "WHERE (cond) x = y" statement or block is
5454 dependence free if cond is not dependent upon writing x,
5455 and the source y is unaffected by the destination x. */
5456 if (!gfc_check_dependency (cblock
->next
->expr1
,
5458 && !gfc_check_dependency (cblock
->next
->expr1
,
5459 cblock
->next
->expr2
, 0))
5460 return gfc_trans_where_3 (cblock
, NULL
);
5462 else if (!eblock
->expr1
5465 && eblock
->next
->op
== EXEC_ASSIGN
5466 && !eblock
->next
->next
)
5468 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5469 block is dependence free if cond is not dependent on writes
5470 to x1 and x2, y1 is not dependent on writes to x2, and y2
5471 is not dependent on writes to x1, and both y's are not
5472 dependent upon their own x's. In addition to this, the
5473 final two dependency checks below exclude all but the same
5474 array reference if the where and elswhere destinations
5475 are the same. In short, this is VERY conservative and this
5476 is needed because the two loops, required by the standard
5477 are coalesced in gfc_trans_where_3. */
5478 if (!gfc_check_dependency (cblock
->next
->expr1
,
5480 && !gfc_check_dependency (eblock
->next
->expr1
,
5482 && !gfc_check_dependency (cblock
->next
->expr1
,
5483 eblock
->next
->expr2
, 1)
5484 && !gfc_check_dependency (eblock
->next
->expr1
,
5485 cblock
->next
->expr2
, 1)
5486 && !gfc_check_dependency (cblock
->next
->expr1
,
5487 cblock
->next
->expr2
, 1)
5488 && !gfc_check_dependency (eblock
->next
->expr1
,
5489 eblock
->next
->expr2
, 1)
5490 && !gfc_check_dependency (cblock
->next
->expr1
,
5491 eblock
->next
->expr1
, 0)
5492 && !gfc_check_dependency (eblock
->next
->expr1
,
5493 cblock
->next
->expr1
, 0))
5494 return gfc_trans_where_3 (cblock
, eblock
);
5498 gfc_start_block (&block
);
5500 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5502 return gfc_finish_block (&block
);
5506 /* CYCLE a DO loop. The label decl has already been created by
5507 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5508 node at the head of the loop. We must mark the label as used. */
5511 gfc_trans_cycle (gfc_code
* code
)
5515 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5516 gcc_assert (cycle_label
);
5518 TREE_USED (cycle_label
) = 1;
5519 return build1_v (GOTO_EXPR
, cycle_label
);
5523 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5524 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5528 gfc_trans_exit (gfc_code
* code
)
5532 exit_label
= code
->ext
.which_construct
->exit_label
;
5533 gcc_assert (exit_label
);
5535 TREE_USED (exit_label
) = 1;
5536 return build1_v (GOTO_EXPR
, exit_label
);
5540 /* Get the initializer expression for the code and expr of an allocate.
5541 When no initializer is needed return NULL. */
5544 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
5546 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
5549 /* An explicit type was given in allocate ( T:: object). */
5550 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
5551 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
5552 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
5553 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
5555 if (gfc_bt_struct (expr
->ts
.type
)
5556 && (expr
->ts
.u
.derived
->attr
.alloc_comp
5557 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
5558 return gfc_default_initializer (&expr
->ts
);
5560 if (expr
->ts
.type
== BT_CLASS
5561 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
5562 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
5563 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
5568 /* Translate the ALLOCATE statement. */
5571 gfc_trans_allocate (gfc_code
* code
)
5574 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
5584 tree al_vptr
, al_len
;
5585 /* If an expr3 is present, then store the tree for accessing its
5586 _vptr, and _len components in the variables, respectively. The
5587 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5588 the trees may be the NULL_TREE indicating that this is not
5589 available for expr3's type. */
5590 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5591 /* Classify what expr3 stores. */
5592 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5596 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
5597 bool needs_caf_sync
, caf_refs_comp
;
5598 gfc_symtree
*newsym
= NULL
;
5599 symbol_attribute caf_attr
;
5600 gfc_actual_arglist
*param_list
;
5602 if (!code
->ext
.alloc
.list
)
5605 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5606 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5607 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5609 is_coarray
= needs_caf_sync
= false;
5611 gfc_init_block (&block
);
5612 gfc_init_block (&post
);
5614 /* STAT= (and maybe ERRMSG=) is present. */
5618 tree gfc_int4_type_node
= gfc_get_int_type (4);
5619 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5621 /* ERRMSG= only makes sense with STAT=. */
5624 gfc_init_se (&se
, NULL
);
5625 se
.want_pointer
= 1;
5626 gfc_conv_expr_lhs (&se
, code
->expr2
);
5628 errlen
= se
.string_length
;
5632 errmsg
= null_pointer_node
;
5633 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5636 /* GOTO destinations. */
5637 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5638 label_finish
= gfc_build_label_decl (NULL_TREE
);
5639 TREE_USED (label_finish
) = 0;
5642 /* When an expr3 is present evaluate it only once. The standards prevent a
5643 dependency of expr3 on the objects in the allocate list. An expr3 can
5644 be pre-evaluated in all cases. One just has to make sure, to use the
5645 correct way, i.e., to get the descriptor or to get a reference
5649 bool vtab_needed
= false, temp_var_needed
= false,
5650 temp_obj_created
= false;
5652 is_coarray
= gfc_is_coarray (code
->expr3
);
5654 /* Figure whether we need the vtab from expr3. */
5655 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5657 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5659 gfc_init_se (&se
, NULL
);
5660 /* When expr3 is a variable, i.e., a very simple expression,
5661 then convert it once here. */
5662 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5663 || code
->expr3
->expr_type
== EXPR_ARRAY
5664 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5666 if (!code
->expr3
->mold
5667 || code
->expr3
->ts
.type
== BT_CHARACTER
5669 || code
->ext
.alloc
.arr_spec_from_expr3
)
5671 /* Convert expr3 to a tree. For all "simple" expression just
5672 get the descriptor or the reference, respectively, depending
5673 on the rank of the expr. */
5674 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5675 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5678 gfc_conv_expr_reference (&se
, code
->expr3
);
5680 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5681 NOP_EXPR, which prevents gfortran from getting the vptr
5682 from the source=-expression. Remove the NOP_EXPR and go
5683 with the POINTER_PLUS_EXPR in this case. */
5684 if (code
->expr3
->ts
.type
== BT_CLASS
5685 && TREE_CODE (se
.expr
) == NOP_EXPR
5686 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5687 == POINTER_PLUS_EXPR
5689 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5691 /* Create a temp variable only for component refs to prevent
5692 having to go through the full deref-chain each time and to
5693 simplfy computation of array properties. */
5694 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5699 /* In all other cases evaluate the expr3. */
5700 symbol_attribute attr
;
5701 /* Get the descriptor for all arrays, that are not allocatable or
5702 pointer, because the latter are descriptors already.
5703 The exception are function calls returning a class object:
5704 The descriptor is stored in their results _data component, which
5705 is easier to access, when first a temporary variable for the
5706 result is created and the descriptor retrieved from there. */
5707 attr
= gfc_expr_attr (code
->expr3
);
5708 if (code
->expr3
->rank
!= 0
5709 && ((!attr
.allocatable
&& !attr
.pointer
)
5710 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5711 && (code
->expr3
->ts
.type
!= BT_CLASS
5712 || (code
->expr3
->value
.function
.isym
5713 && code
->expr3
->value
.function
.isym
5714 ->transformational
)))))
5715 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5717 gfc_conv_expr_reference (&se
, code
->expr3
);
5718 if (code
->expr3
->ts
.type
== BT_CLASS
)
5719 gfc_conv_class_to_class (&se
, code
->expr3
,
5723 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
5725 gfc_add_block_to_block (&block
, &se
.pre
);
5726 gfc_add_block_to_block (&post
, &se
.post
);
5728 /* Special case when string in expr3 is zero. */
5729 if (code
->expr3
->ts
.type
== BT_CHARACTER
5730 && integer_zerop (se
.string_length
))
5732 gfc_init_se (&se
, NULL
);
5733 temp_var_needed
= false;
5734 expr3_len
= integer_zero_node
;
5737 /* Prevent aliasing, i.e., se.expr may be already a
5738 variable declaration. */
5739 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5742 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5744 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5746 /* Get the array descriptor and prepare it to be assigned to the
5747 temporary variable var. For classes the array descriptor is
5748 in the _data component and the object goes into the
5749 GFC_DECL_SAVED_DESCRIPTOR. */
5750 if (code
->expr3
->ts
.type
== BT_CLASS
5751 && code
->expr3
->rank
!= 0)
5753 /* When an array_ref was in expr3, then the descriptor is the
5755 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5757 desc
= TREE_OPERAND (tmp
, 0);
5762 tmp
= gfc_class_data_get (tmp
);
5764 if (code
->ext
.alloc
.arr_spec_from_expr3
)
5768 desc
= !is_coarray
? se
.expr
5769 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5770 /* We need a regular (non-UID) symbol here, therefore give a
5772 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5773 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5775 gfc_allocate_lang_decl (var
);
5776 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5778 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5781 if (se
.string_length
)
5782 /* Evaluate it assuming that it also is complicated like expr3. */
5783 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5788 expr3_len
= se
.string_length
;
5791 /* Deallocate any allocatable components in expressions that use a
5792 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
5793 E.g. temporaries of a function call need freeing of their components
5795 if ((code
->expr3
->ts
.type
== BT_DERIVED
5796 || code
->expr3
->ts
.type
== BT_CLASS
)
5797 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
5798 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
)
5800 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
5801 expr3
, code
->expr3
->rank
);
5802 gfc_prepend_expr_to_block (&post
, tmp
);
5805 /* Store what the expr3 is to be used for. */
5806 if (e3_is
== E3_UNSET
)
5807 e3_is
= expr3
!= NULL_TREE
?
5808 (code
->ext
.alloc
.arr_spec_from_expr3
?
5810 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
5813 /* Figure how to get the _vtab entry. This also obtains the tree
5814 expression for accessing the _len component, because only
5815 unlimited polymorphic objects, which are a subcategory of class
5816 types, have a _len component. */
5817 if (code
->expr3
->ts
.type
== BT_CLASS
)
5820 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
5821 build_fold_indirect_ref (expr3
): expr3
;
5822 /* Polymorphic SOURCE: VPTR must be determined at run time.
5823 expr3 may be a temporary array declaration, therefore check for
5824 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5825 if (tmp
!= NULL_TREE
5826 && (e3_is
== E3_DESC
5827 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
5828 && (VAR_P (tmp
) || !code
->expr3
->ref
))
5829 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
5830 tmp
= gfc_class_vptr_get (expr3
);
5833 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5834 gfc_add_vptr_component (rhs
);
5835 gfc_init_se (&se
, NULL
);
5836 se
.want_pointer
= 1;
5837 gfc_conv_expr (&se
, rhs
);
5839 gfc_free_expr (rhs
);
5841 /* Set the element size. */
5842 expr3_esize
= gfc_vptr_size_get (tmp
);
5845 /* Initialize the ref to the _len component. */
5846 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5848 /* Same like for retrieving the _vptr. */
5849 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5850 expr3_len
= gfc_class_len_get (expr3
);
5853 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5854 gfc_add_len_component (rhs
);
5855 gfc_init_se (&se
, NULL
);
5856 gfc_conv_expr (&se
, rhs
);
5857 expr3_len
= se
.expr
;
5858 gfc_free_expr (rhs
);
5864 /* When the object to allocate is polymorphic type, then it
5865 needs its vtab set correctly, so deduce the required _vtab
5866 and _len from the source expression. */
5869 /* VPTR is fixed at compile time. */
5872 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5874 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5875 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5878 /* _len component needs to be set, when ts is a character
5880 if (expr3_len
== NULL_TREE
5881 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5883 if (code
->expr3
->ts
.u
.cl
5884 && code
->expr3
->ts
.u
.cl
->length
)
5886 gfc_init_se (&se
, NULL
);
5887 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5888 gfc_add_block_to_block (&block
, &se
.pre
);
5889 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5891 gcc_assert (expr3_len
);
5893 /* For character arrays only the kind's size is needed, because
5894 the array mem_size is _len * (elem_size = kind_size).
5895 For all other get the element size in the normal way. */
5896 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5897 expr3_esize
= TYPE_SIZE_UNIT (
5898 gfc_get_char_type (code
->expr3
->ts
.kind
));
5900 expr3_esize
= TYPE_SIZE_UNIT (
5901 gfc_typenode_for_spec (&code
->expr3
->ts
));
5903 gcc_assert (expr3_esize
);
5904 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5905 if (e3_is
== E3_MOLD
)
5906 /* The expr3 is no longer valid after this point. */
5909 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5911 /* Compute the explicit typespec given only once for all objects
5913 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5914 expr3_esize
= TYPE_SIZE_UNIT (
5915 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5919 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
);
5920 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5921 gfc_init_se (&se_sz
, NULL
);
5922 gfc_conv_expr (&se_sz
, sz
);
5924 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5925 tmp
= TYPE_SIZE_UNIT (tmp
);
5926 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5927 gfc_add_block_to_block (&block
, &se_sz
.pre
);
5928 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5929 TREE_TYPE (se_sz
.expr
),
5931 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
5935 /* The routine gfc_trans_assignment () already implements all
5936 techniques needed. Unfortunately we may have a temporary
5937 variable for the source= expression here. When that is the
5938 case convert this variable into a temporary gfc_expr of type
5939 EXPR_VARIABLE and used it as rhs for the assignment. The
5940 advantage is, that we get scalarizer support for free,
5941 don't have to take care about scalar to array treatment and
5942 will benefit of every enhancements gfc_trans_assignment ()
5944 No need to check whether e3_is is E3_UNSET, because that is
5945 done by expr3 != NULL_TREE.
5946 Exclude variables since the following block does not handle
5947 array sections. In any case, there is no harm in sending
5948 variables to gfc_trans_assignment because there is no
5949 evaluation of variables. */
5952 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
5953 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
5954 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5956 /* Build a temporary symtree and symbol. Do not add it to the current
5957 namespace to prevent accidently modifying a colliding
5959 newsym
= XCNEW (gfc_symtree
);
5960 /* The name of the symtree should be unique, because gfc_create_var ()
5961 took care about generating the identifier. */
5963 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
5964 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5965 /* The backend_decl is known. It is expr3, which is inserted
5967 newsym
->n
.sym
->backend_decl
= expr3
;
5968 e3rhs
= gfc_get_expr ();
5969 e3rhs
->rank
= code
->expr3
->rank
;
5970 e3rhs
->symtree
= newsym
;
5971 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
5972 newsym
->n
.sym
->attr
.referenced
= 1;
5973 e3rhs
->expr_type
= EXPR_VARIABLE
;
5974 e3rhs
->where
= code
->expr3
->where
;
5975 /* Set the symbols type, upto it was BT_UNKNOWN. */
5976 if (IS_CLASS_ARRAY (code
->expr3
)
5977 && code
->expr3
->expr_type
== EXPR_FUNCTION
5978 && code
->expr3
->value
.function
.isym
5979 && code
->expr3
->value
.function
.isym
->transformational
)
5981 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5983 else if (code
->expr3
->ts
.type
== BT_CLASS
5984 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
5985 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
5987 e3rhs
->ts
= code
->expr3
->ts
;
5988 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5989 /* Check whether the expr3 is array valued. */
5992 gfc_array_spec
*arr
;
5993 arr
= gfc_get_array_spec ();
5994 arr
->rank
= e3rhs
->rank
;
5995 arr
->type
= AS_DEFERRED
;
5996 /* Set the dimension and pointer attribute for arrays
5997 to be on the safe side. */
5998 newsym
->n
.sym
->attr
.dimension
= 1;
5999 newsym
->n
.sym
->attr
.pointer
= 1;
6000 newsym
->n
.sym
->as
= arr
;
6001 if (IS_CLASS_ARRAY (code
->expr3
)
6002 && code
->expr3
->expr_type
== EXPR_FUNCTION
6003 && code
->expr3
->value
.function
.isym
6004 && code
->expr3
->value
.function
.isym
->transformational
)
6006 gfc_array_spec
*tarr
;
6007 tarr
= gfc_get_array_spec ();
6009 e3rhs
->ts
.u
.derived
->as
= tarr
;
6011 gfc_add_full_array_ref (e3rhs
, arr
);
6013 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
6014 newsym
->n
.sym
->attr
.pointer
= 1;
6015 /* The string length is known, too. Set it for char arrays. */
6016 if (e3rhs
->ts
.type
== BT_CHARACTER
)
6017 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
6018 gfc_commit_symbol (newsym
->n
.sym
);
6021 e3rhs
= gfc_copy_expr (code
->expr3
);
6024 /* Loop over all objects to allocate. */
6025 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6027 expr
= gfc_copy_expr (al
->expr
);
6028 /* UNLIMITED_POLY () needs the _data component to be set, when
6029 expr is a unlimited polymorphic object. But the _data component
6030 has not been set yet, so check the derived type's attr for the
6031 unlimited polymorphic flag to be safe. */
6032 upoly_expr
= UNLIMITED_POLY (expr
)
6033 || (expr
->ts
.type
== BT_DERIVED
6034 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
6035 gfc_init_se (&se
, NULL
);
6037 /* For class types prepare the expressions to ref the _vptr
6038 and the _len component. The latter for unlimited polymorphic
6040 if (expr
->ts
.type
== BT_CLASS
)
6042 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
6043 gfc_add_data_component (expr
);
6044 /* Prep the vptr handle. */
6045 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
6046 gfc_add_vptr_component (expr_ref_vptr
);
6047 se
.want_pointer
= 1;
6048 gfc_conv_expr (&se
, expr_ref_vptr
);
6050 se
.want_pointer
= 0;
6051 gfc_free_expr (expr_ref_vptr
);
6052 /* Allocated unlimited polymorphic objects always have a _len
6056 expr_ref_len
= gfc_copy_expr (al
->expr
);
6057 gfc_add_len_component (expr_ref_len
);
6058 gfc_conv_expr (&se
, expr_ref_len
);
6060 gfc_free_expr (expr_ref_len
);
6063 /* In a loop ensure that all loop variable dependent variables
6064 are initialized at the same spot in all execution paths. */
6068 al_vptr
= al_len
= NULL_TREE
;
6070 se
.want_pointer
= 1;
6071 se
.descriptor_only
= 1;
6073 gfc_conv_expr (&se
, expr
);
6074 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6075 /* se.string_length now stores the .string_length variable of expr
6076 needed to allocate character(len=:) arrays. */
6077 al_len
= se
.string_length
;
6079 al_len_needs_set
= al_len
!= NULL_TREE
;
6080 /* When allocating an array one can not use much of the
6081 pre-evaluated expr3 expressions, because for most of them the
6082 scalarizer is needed which is not available in the pre-evaluation
6083 step. Therefore gfc_array_allocate () is responsible (and able)
6084 to handle the complete array allocation. Only the element size
6085 needs to be provided, which is done most of the time by the
6086 pre-evaluation step. */
6088 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6089 || code
->expr3
->ts
.type
== BT_CLASS
))
6091 /* When al is an array, then the element size for each element
6092 in the array is needed, which is the product of the len and
6093 esize for char arrays. For unlimited polymorphics len can be
6094 zero, therefore take the maximum of len and one. */
6095 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6096 TREE_TYPE (expr3_len
),
6097 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6099 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6100 TREE_TYPE (expr3_esize
), expr3_esize
,
6101 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6105 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6106 label_finish
, tmp
, &nelems
,
6107 e3rhs
? e3rhs
: code
->expr3
,
6108 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6109 code
->expr3
!= NULL
&& e3_is
== E3_DESC
6110 && code
->expr3
->expr_type
== EXPR_ARRAY
))
6112 /* A scalar or derived type. First compute the size to
6115 expr3_len is set when expr3 is an unlimited polymorphic
6116 object or a deferred length string. */
6117 if (expr3_len
!= NULL_TREE
)
6119 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6120 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6121 TREE_TYPE (expr3_esize
),
6123 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6124 /* expr3 is a deferred length string, i.e., we are
6129 /* For unlimited polymorphic enties build
6130 (len > 0) ? element_size * len : element_size
6131 to compute the number of bytes to allocate.
6132 This allows the allocation of unlimited polymorphic
6133 objects from an expr3 that is also unlimited
6134 polymorphic and stores a _len dependent object,
6136 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6137 boolean_type_node
, expr3_len
,
6139 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6140 TREE_TYPE (expr3_esize
),
6141 memsz
, tmp
, expr3_esize
);
6144 else if (expr3_esize
!= NULL_TREE
)
6145 /* Any other object in expr3 just needs element size in
6147 memsz
= expr3_esize
;
6148 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6150 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6152 /* Allocating deferred length char arrays need the length
6153 to allocate in the alloc_type_spec. But also unlimited
6154 polymorphic objects may be allocated as char arrays.
6155 Both are handled here. */
6156 gfc_init_se (&se_sz
, NULL
);
6157 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6158 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6159 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6160 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6161 expr3_len
= se_sz
.expr
;
6162 tmp_expr3_len_flag
= true;
6163 tmp
= TYPE_SIZE_UNIT (
6164 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6165 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6167 fold_convert (TREE_TYPE (tmp
),
6171 else if (expr
->ts
.type
== BT_CHARACTER
)
6173 /* Compute the number of bytes needed to allocate a fixed
6174 length char array. */
6175 gcc_assert (se
.string_length
!= NULL_TREE
);
6176 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6177 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6178 TREE_TYPE (tmp
), tmp
,
6179 fold_convert (TREE_TYPE (tmp
),
6182 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6183 /* Handle all types, where the alloc_type_spec is set. */
6184 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6186 /* Handle size computation of the type declared to alloc. */
6187 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6189 /* Store the caf-attributes for latter use. */
6190 if (flag_coarray
== GFC_FCOARRAY_LIB
6191 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6194 /* Scalar allocatable components in coarray'ed derived types make
6195 it here and are treated now. */
6196 tree caf_decl
, token
;
6200 /* Set flag, to add synchronize after the allocate. */
6201 needs_caf_sync
= needs_caf_sync
6202 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6204 gfc_init_se (&caf_se
, NULL
);
6206 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6207 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6209 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6210 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6211 gfc_build_addr_expr (NULL_TREE
, token
),
6212 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6213 label_finish
, expr
, 1);
6215 /* Allocate - for non-pointers with re-alloc checking. */
6216 else if (gfc_expr_attr (expr
).allocatable
)
6217 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6218 NULL_TREE
, stat
, errmsg
, errlen
,
6219 label_finish
, expr
, 0);
6221 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6225 /* Allocating coarrays needs a sync after the allocate executed.
6226 Set the flag to add the sync after all objects are allocated. */
6227 if (flag_coarray
== GFC_FCOARRAY_LIB
6228 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6232 needs_caf_sync
= needs_caf_sync
6233 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6236 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6237 && expr3_len
!= NULL_TREE
)
6239 /* Arrays need to have a _len set before the array
6240 descriptor is filled. */
6241 gfc_add_modify (&block
, al_len
,
6242 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6243 /* Prevent setting the length twice. */
6244 al_len_needs_set
= false;
6246 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6247 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6249 /* Cover the cases where a string length is explicitly
6250 specified by a type spec for deferred length character
6251 arrays or unlimited polymorphic objects without a
6252 source= or mold= expression. */
6253 gfc_init_se (&se_sz
, NULL
);
6254 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6255 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6256 gfc_add_modify (&block
, al_len
,
6257 fold_convert (TREE_TYPE (al_len
),
6259 al_len_needs_set
= false;
6263 gfc_add_block_to_block (&block
, &se
.pre
);
6265 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6268 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6269 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6270 boolean_type_node
, stat
,
6271 build_int_cst (TREE_TYPE (stat
), 0));
6272 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6273 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6274 tmp
, build_empty_stmt (input_location
));
6275 gfc_add_expr_to_block (&block
, tmp
);
6278 /* Set the vptr only when no source= is set. When source= is set, then
6279 the trans_assignment below will set the vptr. */
6280 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6282 if (expr3_vptr
!= NULL_TREE
)
6283 /* The vtab is already known, so just assign it. */
6284 gfc_add_modify (&block
, al_vptr
,
6285 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6288 /* VPTR is fixed at compile time. */
6293 /* Although expr3 is pre-evaluated above, it may happen,
6294 that for arrays or in mold= cases the pre-evaluation
6295 was not successful. In these rare cases take the vtab
6296 from the typespec of expr3 here. */
6297 ts
= &code
->expr3
->ts
;
6298 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6299 /* The alloc_type_spec gives the type to allocate or the
6300 al is unlimited polymorphic, which enforces the use of
6301 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6302 ts
= &code
->ext
.alloc
.ts
;
6304 /* Prepare for setting the vtab as declared. */
6307 vtab
= gfc_find_vtab (ts
);
6309 tmp
= gfc_build_addr_expr (NULL_TREE
,
6310 gfc_get_symbol_decl (vtab
));
6311 gfc_add_modify (&block
, al_vptr
,
6312 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6316 /* Add assignment for string length. */
6317 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6319 if (expr3_len
!= NULL_TREE
)
6321 gfc_add_modify (&block
, al_len
,
6322 fold_convert (TREE_TYPE (al_len
),
6324 /* When tmp_expr3_len_flag is set, then expr3_len is
6325 abused to carry the length information from the
6326 alloc_type. Clear it to prevent setting incorrect len
6327 information in future loop iterations. */
6328 if (tmp_expr3_len_flag
)
6329 /* No need to reset tmp_expr3_len_flag, because the
6330 presence of an expr3 can not change within in the
6332 expr3_len
= NULL_TREE
;
6334 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6335 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6337 /* Cover the cases where a string length is explicitly
6338 specified by a type spec for deferred length character
6339 arrays or unlimited polymorphic objects without a
6340 source= or mold= expression. */
6341 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6343 gfc_init_se (&se_sz
, NULL
);
6344 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6345 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6346 gfc_add_modify (&block
, al_len
,
6347 fold_convert (TREE_TYPE (al_len
),
6351 gfc_add_modify (&block
, al_len
,
6352 fold_convert (TREE_TYPE (al_len
),
6356 /* No length information needed, because type to allocate
6357 has no length. Set _len to 0. */
6358 gfc_add_modify (&block
, al_len
,
6359 fold_convert (TREE_TYPE (al_len
),
6360 integer_zero_node
));
6364 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6366 /* Initialization via SOURCE block (or static default initializer).
6367 Switch off automatic reallocation since we have just done the
6369 int realloc_lhs
= flag_realloc_lhs
;
6370 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6371 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6372 flag_realloc_lhs
= 0;
6373 tmp
= gfc_trans_assignment (init_expr
, rhs
, false, false, true,
6375 flag_realloc_lhs
= realloc_lhs
;
6376 /* Free the expression allocated for init_expr. */
6377 gfc_free_expr (init_expr
);
6379 gfc_free_expr (rhs
);
6380 gfc_add_expr_to_block (&block
, tmp
);
6382 /* Set KIND and LEN PDT components and allocate those that are
6384 else if (expr
->ts
.type
== BT_DERIVED
6385 && expr
->ts
.u
.derived
->attr
.pdt_type
)
6387 if (code
->expr3
&& code
->expr3
->param_list
)
6388 param_list
= code
->expr3
->param_list
;
6389 else if (expr
->param_list
)
6390 param_list
= expr
->param_list
;
6392 param_list
= expr
->symtree
->n
.sym
->param_list
;
6393 tmp
= gfc_allocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
,
6394 expr
->rank
, param_list
);
6395 gfc_add_expr_to_block (&block
, tmp
);
6397 /* Ditto for CLASS expressions. */
6398 else if (expr
->ts
.type
== BT_CLASS
6399 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
)
6401 if (code
->expr3
&& code
->expr3
->param_list
)
6402 param_list
= code
->expr3
->param_list
;
6403 else if (expr
->param_list
)
6404 param_list
= expr
->param_list
;
6406 param_list
= expr
->symtree
->n
.sym
->param_list
;
6407 tmp
= gfc_allocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6408 se
.expr
, expr
->rank
, param_list
);
6409 gfc_add_expr_to_block (&block
, tmp
);
6411 else if (code
->expr3
&& code
->expr3
->mold
6412 && code
->expr3
->ts
.type
== BT_CLASS
)
6414 /* Use class_init_assign to initialize expr. */
6416 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6417 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
);
6418 tmp
= gfc_trans_class_init_assign (ini
);
6419 gfc_free_statements (ini
);
6420 gfc_add_expr_to_block (&block
, tmp
);
6422 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
6424 /* Use class_init_assign to initialize expr. */
6426 int realloc_lhs
= flag_realloc_lhs
;
6427 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6428 ini
->expr1
= gfc_expr_to_initialize (expr
);
6429 ini
->expr2
= init_expr
;
6430 flag_realloc_lhs
= 0;
6431 tmp
= gfc_trans_init_assign (ini
);
6432 flag_realloc_lhs
= realloc_lhs
;
6433 gfc_free_statements (ini
);
6434 /* Init_expr is freeed by above free_statements, just need to null
6437 gfc_add_expr_to_block (&block
, tmp
);
6440 /* Nullify all pointers in derived type coarrays. This registers a
6441 token for them which allows their allocation. */
6444 gfc_symbol
*type
= NULL
;
6445 symbol_attribute caf_attr
;
6447 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6448 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
6450 type
= code
->ext
.alloc
.ts
.u
.derived
;
6451 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
6452 gfc_clear_attr (&caf_attr
);
6454 else if (expr
->ts
.type
== BT_DERIVED
6455 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
6457 type
= expr
->ts
.u
.derived
;
6459 caf_attr
= gfc_caf_attr (expr
, true);
6462 /* Initialize the tokens of pointer components in derived type
6466 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
6467 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
6468 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
6469 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
6470 gfc_add_expr_to_block (&block
, tmp
);
6474 gfc_free_expr (expr
);
6481 gfc_free_symbol (newsym
->n
.sym
);
6484 gfc_free_expr (e3rhs
);
6489 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6490 gfc_add_expr_to_block (&block
, tmp
);
6493 /* ERRMSG - only useful if STAT is present. */
6494 if (code
->expr1
&& code
->expr2
)
6496 const char *msg
= "Attempt to allocate an allocated object";
6497 tree slen
, dlen
, errmsg_str
;
6498 stmtblock_t errmsg_block
;
6500 gfc_init_block (&errmsg_block
);
6502 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6503 gfc_add_modify (&errmsg_block
, errmsg_str
,
6504 gfc_build_addr_expr (pchar_type_node
,
6505 gfc_build_localized_cstring_const (msg
)));
6507 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6508 dlen
= gfc_get_expr_charlen (code
->expr2
);
6509 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6510 TREE_TYPE (slen
), dlen
, slen
);
6512 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6513 code
->expr2
->ts
.kind
,
6515 gfc_default_character_kind
);
6516 dlen
= gfc_finish_block (&errmsg_block
);
6518 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6519 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6521 tmp
= build3_v (COND_EXPR
, tmp
,
6522 dlen
, build_empty_stmt (input_location
));
6524 gfc_add_expr_to_block (&block
, tmp
);
6530 if (TREE_USED (label_finish
))
6532 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6533 gfc_add_expr_to_block (&block
, tmp
);
6536 gfc_init_se (&se
, NULL
);
6537 gfc_conv_expr_lhs (&se
, code
->expr1
);
6538 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6539 gfc_add_modify (&block
, se
.expr
, tmp
);
6544 /* Add a sync all after the allocation has been executed. */
6545 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
6546 3, null_pointer_node
, null_pointer_node
,
6548 gfc_add_expr_to_block (&post
, tmp
);
6551 gfc_add_block_to_block (&block
, &se
.post
);
6552 gfc_add_block_to_block (&block
, &post
);
6554 return gfc_finish_block (&block
);
6558 /* Translate a DEALLOCATE statement. */
6561 gfc_trans_deallocate (gfc_code
*code
)
6565 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6566 tree label_finish
, label_errmsg
;
6569 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6570 label_finish
= label_errmsg
= NULL_TREE
;
6572 gfc_start_block (&block
);
6574 /* Count the number of failed deallocations. If deallocate() was
6575 called with STAT= , then set STAT to the count. If deallocate
6576 was called with ERRMSG, then set ERRMG to a string. */
6579 tree gfc_int4_type_node
= gfc_get_int_type (4);
6581 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6582 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6584 /* GOTO destinations. */
6585 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6586 label_finish
= gfc_build_label_decl (NULL_TREE
);
6587 TREE_USED (label_finish
) = 0;
6590 /* Set ERRMSG - only needed if STAT is available. */
6591 if (code
->expr1
&& code
->expr2
)
6593 gfc_init_se (&se
, NULL
);
6594 se
.want_pointer
= 1;
6595 gfc_conv_expr_lhs (&se
, code
->expr2
);
6597 errlen
= se
.string_length
;
6600 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6602 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6603 bool is_coarray
= false, is_coarray_array
= false;
6606 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6608 if (expr
->ts
.type
== BT_CLASS
)
6609 gfc_add_data_component (expr
);
6611 gfc_init_se (&se
, NULL
);
6612 gfc_start_block (&se
.pre
);
6614 se
.want_pointer
= 1;
6615 se
.descriptor_only
= 1;
6616 gfc_conv_expr (&se
, expr
);
6618 /* Deallocate PDT components that are parameterized. */
6620 if (expr
->ts
.type
== BT_DERIVED
6621 && expr
->ts
.u
.derived
->attr
.pdt_type
6622 && expr
->symtree
->n
.sym
->param_list
)
6623 tmp
= gfc_deallocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
, expr
->rank
);
6624 else if (expr
->ts
.type
== BT_CLASS
6625 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
6626 && expr
->symtree
->n
.sym
->param_list
)
6627 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6628 se
.expr
, expr
->rank
);
6631 gfc_add_expr_to_block (&block
, tmp
);
6633 if (flag_coarray
== GFC_FCOARRAY_LIB
6634 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
6637 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
6638 if (caf_attr
.codimension
)
6641 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
6642 || caf_attr
.coarray_comp
;
6644 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6645 /* When the expression to deallocate is referencing a
6646 component, then only deallocate it, but do not
6648 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
6649 | (comp_ref
&& !caf_attr
.coarray_comp
6650 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
6654 if (expr
->rank
|| is_coarray_array
)
6658 if (gfc_bt_struct (expr
->ts
.type
)
6659 && expr
->ts
.u
.derived
->attr
.alloc_comp
6660 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6662 gfc_ref
*last
= NULL
;
6664 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6665 if (ref
->type
== REF_COMPONENT
)
6668 /* Do not deallocate the components of a derived type
6669 ultimate pointer component. */
6670 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6671 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6673 if (is_coarray
&& expr
->rank
== 0
6674 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
6675 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6677 /* Add the ref to the data member only, when this is not
6678 a regular array or deallocate_alloc_comp will try to
6680 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
6684 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
6685 expr
->rank
, caf_mode
);
6686 gfc_add_expr_to_block (&se
.pre
, tmp
);
6690 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6692 gfc_coarray_deregtype caf_dtype
;
6695 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
6696 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
6697 : GFC_CAF_COARRAY_DEREGISTER
;
6699 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
6700 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
6701 label_finish
, false, expr
,
6703 gfc_add_expr_to_block (&se
.pre
, tmp
);
6705 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6706 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6707 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6710 /* class.c(finalize_component) generates these, when a
6711 finalizable entity has a non-allocatable derived type array
6712 component, which has allocatable components. Obtain the
6713 derived type of the array and deallocate the allocatable
6715 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6717 if (ref
->u
.c
.component
->attr
.dimension
6718 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6722 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6723 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6726 tmp
= gfc_deallocate_alloc_comp
6727 (ref
->u
.c
.component
->ts
.u
.derived
,
6728 se
.expr
, expr
->rank
);
6729 gfc_add_expr_to_block (&se
.pre
, tmp
);
6733 if (al
->expr
->ts
.type
== BT_CLASS
)
6735 gfc_reset_vptr (&se
.pre
, al
->expr
);
6736 if (UNLIMITED_POLY (al
->expr
)
6737 || (al
->expr
->ts
.type
== BT_DERIVED
6738 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6739 /* Clear _len, too. */
6740 gfc_reset_len (&se
.pre
, al
->expr
);
6745 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
6747 al
->expr
->ts
, is_coarray
);
6748 gfc_add_expr_to_block (&se
.pre
, tmp
);
6750 /* Set to zero after deallocation. */
6751 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6753 build_int_cst (TREE_TYPE (se
.expr
), 0));
6754 gfc_add_expr_to_block (&se
.pre
, tmp
);
6756 if (al
->expr
->ts
.type
== BT_CLASS
)
6758 gfc_reset_vptr (&se
.pre
, al
->expr
);
6759 if (UNLIMITED_POLY (al
->expr
)
6760 || (al
->expr
->ts
.type
== BT_DERIVED
6761 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6762 /* Clear _len, too. */
6763 gfc_reset_len (&se
.pre
, al
->expr
);
6771 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6772 build_int_cst (TREE_TYPE (stat
), 0));
6773 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6774 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6775 build1_v (GOTO_EXPR
, label_errmsg
),
6776 build_empty_stmt (input_location
));
6777 gfc_add_expr_to_block (&se
.pre
, tmp
);
6780 tmp
= gfc_finish_block (&se
.pre
);
6781 gfc_add_expr_to_block (&block
, tmp
);
6782 gfc_free_expr (expr
);
6787 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6788 gfc_add_expr_to_block (&block
, tmp
);
6791 /* Set ERRMSG - only needed if STAT is available. */
6792 if (code
->expr1
&& code
->expr2
)
6794 const char *msg
= "Attempt to deallocate an unallocated object";
6795 stmtblock_t errmsg_block
;
6796 tree errmsg_str
, slen
, dlen
, cond
;
6798 gfc_init_block (&errmsg_block
);
6800 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6801 gfc_add_modify (&errmsg_block
, errmsg_str
,
6802 gfc_build_addr_expr (pchar_type_node
,
6803 gfc_build_localized_cstring_const (msg
)));
6804 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6805 dlen
= gfc_get_expr_charlen (code
->expr2
);
6807 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6808 slen
, errmsg_str
, gfc_default_character_kind
);
6809 tmp
= gfc_finish_block (&errmsg_block
);
6811 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6812 build_int_cst (TREE_TYPE (stat
), 0));
6813 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6814 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6815 build_empty_stmt (input_location
));
6817 gfc_add_expr_to_block (&block
, tmp
);
6820 if (code
->expr1
&& TREE_USED (label_finish
))
6822 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6823 gfc_add_expr_to_block (&block
, tmp
);
6829 gfc_init_se (&se
, NULL
);
6830 gfc_conv_expr_lhs (&se
, code
->expr1
);
6831 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6832 gfc_add_modify (&block
, se
.expr
, tmp
);
6835 return gfc_finish_block (&block
);
6838 #include "gt-fortran-trans-stmt.h"