1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
30 #include "stringpool.h"
31 #include "fold-const.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
36 #include "dependency.h"
38 typedef struct iter_info
44 struct iter_info
*next
;
48 typedef struct forall_info
55 struct forall_info
*prev_nest
;
60 static void gfc_trans_where_2 (gfc_code
*, tree
, bool,
61 forall_info
*, stmtblock_t
*);
63 /* Translate a F95 label number to a LABEL_EXPR. */
66 gfc_trans_label_here (gfc_code
* code
)
68 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
72 /* Given a variable expression which has been ASSIGNed to, find the decl
73 containing the auxiliary variables. For variables in common blocks this
77 gfc_conv_label_variable (gfc_se
* se
, gfc_expr
* expr
)
79 gcc_assert (expr
->symtree
->n
.sym
->attr
.assign
== 1);
80 gfc_conv_expr (se
, expr
);
81 /* Deals with variable in common block. Get the field declaration. */
82 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
83 se
->expr
= TREE_OPERAND (se
->expr
, 1);
84 /* Deals with dummy argument. Get the parameter declaration. */
85 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
86 se
->expr
= TREE_OPERAND (se
->expr
, 0);
89 /* Translate a label assignment statement. */
92 gfc_trans_label_assign (gfc_code
* code
)
101 /* Start a new block. */
102 gfc_init_se (&se
, NULL
);
103 gfc_start_block (&se
.pre
);
104 gfc_conv_label_variable (&se
, code
->expr1
);
106 len
= GFC_DECL_STRING_LEN (se
.expr
);
107 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
109 label_tree
= gfc_get_label_decl (code
->label1
);
111 if (code
->label1
->defined
== ST_LABEL_TARGET
112 || code
->label1
->defined
== ST_LABEL_DO_TARGET
)
114 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
115 len_tree
= integer_minus_one_node
;
119 gfc_expr
*format
= code
->label1
->format
;
121 label_len
= format
->value
.character
.length
;
122 len_tree
= build_int_cst (gfc_charlen_type_node
, label_len
);
123 label_tree
= gfc_build_wide_string_const (format
->ts
.kind
, label_len
+ 1,
124 format
->value
.character
.string
);
125 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
128 gfc_add_modify (&se
.pre
, len
, len_tree
);
129 gfc_add_modify (&se
.pre
, addr
, label_tree
);
131 return gfc_finish_block (&se
.pre
);
134 /* Translate a GOTO statement. */
137 gfc_trans_goto (gfc_code
* code
)
139 locus loc
= code
->loc
;
145 if (code
->label1
!= NULL
)
146 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
149 gfc_init_se (&se
, NULL
);
150 gfc_start_block (&se
.pre
);
151 gfc_conv_label_variable (&se
, code
->expr1
);
152 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
153 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
154 build_int_cst (TREE_TYPE (tmp
), -1));
155 gfc_trans_runtime_check (true, false, tmp
, &se
.pre
, &loc
,
156 "Assigned label is not a target label");
158 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
160 /* We're going to ignore a label list. It does not really change the
161 statement's semantics (because it is just a further restriction on
162 what's legal code); before, we were comparing label addresses here, but
163 that's a very fragile business and may break with optimization. So
166 target
= fold_build1_loc (input_location
, GOTO_EXPR
, void_type_node
,
168 gfc_add_expr_to_block (&se
.pre
, target
);
169 return gfc_finish_block (&se
.pre
);
173 /* Translate an ENTRY statement. Just adds a label for this entry point. */
175 gfc_trans_entry (gfc_code
* code
)
177 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
181 /* Replace a gfc_ss structure by another both in the gfc_se struct
182 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
183 to replace a variable ss by the corresponding temporary. */
186 replace_ss (gfc_se
*se
, gfc_ss
*old_ss
, gfc_ss
*new_ss
)
188 gfc_ss
**sess
, **loopss
;
190 /* The old_ss is a ss for a single variable. */
191 gcc_assert (old_ss
->info
->type
== GFC_SS_SECTION
);
193 for (sess
= &(se
->ss
); *sess
!= gfc_ss_terminator
; sess
= &((*sess
)->next
))
196 gcc_assert (*sess
!= gfc_ss_terminator
);
199 new_ss
->next
= old_ss
->next
;
202 for (loopss
= &(se
->loop
->ss
); *loopss
!= gfc_ss_terminator
;
203 loopss
= &((*loopss
)->loop_chain
))
204 if (*loopss
== old_ss
)
206 gcc_assert (*loopss
!= gfc_ss_terminator
);
209 new_ss
->loop_chain
= old_ss
->loop_chain
;
210 new_ss
->loop
= old_ss
->loop
;
212 gfc_free_ss (old_ss
);
216 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
217 elemental subroutines. Make temporaries for output arguments if any such
218 dependencies are found. Output arguments are chosen because internal_unpack
219 can be used, as is, to copy the result back to the variable. */
221 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
222 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
223 gfc_dep_check check_variable
)
225 gfc_actual_arglist
*arg0
;
227 gfc_formal_arglist
*formal
;
235 if (loopse
->ss
== NULL
)
240 formal
= gfc_sym_get_dummy_args (sym
);
242 /* Loop over all the arguments testing for dependencies. */
243 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
249 /* Obtain the info structure for the current argument. */
250 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
251 if (ss
->info
->expr
== e
)
254 /* If there is a dependency, create a temporary and use it
255 instead of the variable. */
256 fsym
= formal
? formal
->sym
: NULL
;
257 if (e
->expr_type
== EXPR_VARIABLE
259 && fsym
->attr
.intent
!= INTENT_IN
260 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
261 sym
, arg0
, check_variable
))
263 tree initial
, temptype
;
264 stmtblock_t temp_post
;
267 tmp_ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, ss
->dimen
,
269 gfc_mark_ss_chain_used (tmp_ss
, 1);
270 tmp_ss
->info
->expr
= ss
->info
->expr
;
271 replace_ss (loopse
, ss
, tmp_ss
);
273 /* Obtain the argument descriptor for unpacking. */
274 gfc_init_se (&parmse
, NULL
);
275 parmse
.want_pointer
= 1;
276 gfc_conv_expr_descriptor (&parmse
, e
);
277 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
279 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
280 initialize the array temporary with a copy of the values. */
281 if (fsym
->attr
.intent
== INTENT_INOUT
282 || (fsym
->ts
.type
==BT_DERIVED
283 && fsym
->attr
.intent
== INTENT_OUT
))
284 initial
= parmse
.expr
;
285 /* For class expressions, we always initialize with the copy of
287 else if (e
->ts
.type
== BT_CLASS
)
288 initial
= parmse
.expr
;
292 if (e
->ts
.type
!= BT_CLASS
)
294 /* Find the type of the temporary to create; we don't use the type
295 of e itself as this breaks for subcomponent-references in e
296 (where the type of e is that of the final reference, but
297 parmse.expr's type corresponds to the full derived-type). */
298 /* TODO: Fix this somehow so we don't need a temporary of the whole
299 array but instead only the components referenced. */
300 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
301 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
302 temptype
= TREE_TYPE (temptype
);
303 temptype
= gfc_get_element_type (temptype
);
307 /* For class arrays signal that the size of the dynamic type has to
308 be obtained from the vtable, using the 'initial' expression. */
309 temptype
= NULL_TREE
;
311 /* Generate the temporary. Cleaning up the temporary should be the
312 very last thing done, so we add the code to a new block and add it
313 to se->post as last instructions. */
314 size
= gfc_create_var (gfc_array_index_type
, NULL
);
315 data
= gfc_create_var (pvoid_type_node
, NULL
);
316 gfc_init_block (&temp_post
);
317 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
, tmp_ss
,
318 temptype
, initial
, false, true,
319 false, &arg
->expr
->where
);
320 gfc_add_modify (&se
->pre
, size
, tmp
);
321 tmp
= fold_convert (pvoid_type_node
, tmp_ss
->info
->data
.array
.data
);
322 gfc_add_modify (&se
->pre
, data
, tmp
);
324 /* Update other ss' delta. */
325 gfc_set_delta (loopse
->loop
);
327 /* Copy the result back using unpack..... */
328 if (e
->ts
.type
!= BT_CLASS
)
329 tmp
= build_call_expr_loc (input_location
,
330 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
333 /* ... except for class results where the copy is
335 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
336 tmp
= gfc_conv_descriptor_data_get (tmp
);
337 tmp
= build_call_expr_loc (input_location
,
338 builtin_decl_explicit (BUILT_IN_MEMCPY
),
340 fold_convert (size_type_node
, size
));
342 gfc_add_expr_to_block (&se
->post
, tmp
);
344 /* parmse.pre is already added above. */
345 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
346 gfc_add_block_to_block (&se
->post
, &temp_post
);
352 /* Get the interface symbol for the procedure corresponding to the given call.
353 We can't get the procedure symbol directly as we have to handle the case
354 of (deferred) type-bound procedures. */
357 get_proc_ifc_for_call (gfc_code
*c
)
361 gcc_assert (c
->op
== EXEC_ASSIGN_CALL
|| c
->op
== EXEC_CALL
);
363 sym
= gfc_get_proc_ifc_for_expr (c
->expr1
);
365 /* Fall back/last resort try. */
367 sym
= c
->resolved_sym
;
373 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
376 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
377 tree mask
, tree count1
, bool invert
)
381 int has_alternate_specifier
;
382 gfc_dep_check check_variable
;
383 tree index
= NULL_TREE
;
384 tree maskexpr
= NULL_TREE
;
387 /* A CALL starts a new block because the actual arguments may have to
388 be evaluated first. */
389 gfc_init_se (&se
, NULL
);
390 gfc_start_block (&se
.pre
);
392 gcc_assert (code
->resolved_sym
);
394 ss
= gfc_ss_terminator
;
395 if (code
->resolved_sym
->attr
.elemental
)
396 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
,
397 get_proc_ifc_for_call (code
),
400 /* Is not an elemental subroutine call with array valued arguments. */
401 if (ss
== gfc_ss_terminator
)
404 /* Translate the call. */
405 has_alternate_specifier
406 = gfc_conv_procedure_call (&se
, code
->resolved_sym
, code
->ext
.actual
,
409 /* A subroutine without side-effect, by definition, does nothing! */
410 TREE_SIDE_EFFECTS (se
.expr
) = 1;
412 /* Chain the pieces together and return the block. */
413 if (has_alternate_specifier
)
415 gfc_code
*select_code
;
417 select_code
= code
->next
;
418 gcc_assert(select_code
->op
== EXEC_SELECT
);
419 sym
= select_code
->expr1
->symtree
->n
.sym
;
420 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
421 if (sym
->backend_decl
== NULL
)
422 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
423 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
426 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
428 gfc_add_block_to_block (&se
.pre
, &se
.post
);
433 /* An elemental subroutine call with array valued arguments has
441 /* gfc_walk_elemental_function_args renders the ss chain in the
442 reverse order to the actual argument order. */
443 ss
= gfc_reverse_ss (ss
);
445 /* Initialize the loop. */
446 gfc_init_se (&loopse
, NULL
);
447 gfc_init_loopinfo (&loop
);
448 gfc_add_ss_to_loop (&loop
, ss
);
450 gfc_conv_ss_startstride (&loop
);
451 /* TODO: gfc_conv_loop_setup generates a temporary for vector
452 subscripts. This could be prevented in the elemental case
453 as temporaries are handled separatedly
454 (below in gfc_conv_elemental_dependencies). */
455 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
456 gfc_mark_ss_chain_used (ss
, 1);
458 /* Convert the arguments, checking for dependencies. */
459 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
462 /* For operator assignment, do dependency checking. */
463 if (dependency_check
)
464 check_variable
= ELEM_CHECK_VARIABLE
;
466 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
468 gfc_init_se (&depse
, NULL
);
469 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
470 code
->ext
.actual
, check_variable
);
472 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
473 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
475 /* Generate the loop body. */
476 gfc_start_scalarized_body (&loop
, &body
);
477 gfc_init_block (&block
);
481 /* Form the mask expression according to the mask. */
483 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
485 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
486 TREE_TYPE (maskexpr
), maskexpr
);
489 /* Add the subroutine call to the block. */
490 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
491 code
->ext
.actual
, code
->expr1
,
496 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
497 build_empty_stmt (input_location
));
498 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
499 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
500 gfc_array_index_type
,
501 count1
, gfc_index_one_node
);
502 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
505 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
507 gfc_add_block_to_block (&block
, &loopse
.pre
);
508 gfc_add_block_to_block (&block
, &loopse
.post
);
510 /* Finish up the loop block and the loop. */
511 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
512 gfc_trans_scalarizing_loops (&loop
, &body
);
513 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
514 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
515 gfc_add_block_to_block (&se
.pre
, &se
.post
);
516 gfc_cleanup_loop (&loop
);
519 return gfc_finish_block (&se
.pre
);
523 /* Translate the RETURN statement. */
526 gfc_trans_return (gfc_code
* code
)
534 /* If code->expr is not NULL, this return statement must appear
535 in a subroutine and current_fake_result_decl has already
538 result
= gfc_get_fake_result_decl (NULL
, 0);
542 "An alternate return at %L without a * dummy argument",
543 &code
->expr1
->where
);
544 return gfc_generate_return ();
547 /* Start a new block for this statement. */
548 gfc_init_se (&se
, NULL
);
549 gfc_start_block (&se
.pre
);
551 gfc_conv_expr (&se
, code
->expr1
);
553 /* Note that the actually returned expression is a simple value and
554 does not depend on any pointers or such; thus we can clean-up with
555 se.post before returning. */
556 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
557 result
, fold_convert (TREE_TYPE (result
),
559 gfc_add_expr_to_block (&se
.pre
, tmp
);
560 gfc_add_block_to_block (&se
.pre
, &se
.post
);
562 tmp
= gfc_generate_return ();
563 gfc_add_expr_to_block (&se
.pre
, tmp
);
564 return gfc_finish_block (&se
.pre
);
567 return gfc_generate_return ();
571 /* Translate the PAUSE statement. We have to translate this statement
572 to a runtime library call. */
575 gfc_trans_pause (gfc_code
* code
)
577 tree gfc_int4_type_node
= gfc_get_int_type (4);
581 /* Start a new block for this statement. */
582 gfc_init_se (&se
, NULL
);
583 gfc_start_block (&se
.pre
);
586 if (code
->expr1
== NULL
)
588 tmp
= build_int_cst (gfc_int4_type_node
, 0);
589 tmp
= build_call_expr_loc (input_location
,
590 gfor_fndecl_pause_string
, 2,
591 build_int_cst (pchar_type_node
, 0), tmp
);
593 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
595 gfc_conv_expr (&se
, code
->expr1
);
596 tmp
= build_call_expr_loc (input_location
,
597 gfor_fndecl_pause_numeric
, 1,
598 fold_convert (gfc_int4_type_node
, se
.expr
));
602 gfc_conv_expr_reference (&se
, code
->expr1
);
603 tmp
= build_call_expr_loc (input_location
,
604 gfor_fndecl_pause_string
, 2,
605 se
.expr
, se
.string_length
);
608 gfc_add_expr_to_block (&se
.pre
, tmp
);
610 gfc_add_block_to_block (&se
.pre
, &se
.post
);
612 return gfc_finish_block (&se
.pre
);
616 /* Translate the STOP statement. We have to translate this statement
617 to a runtime library call. */
620 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
622 tree gfc_int4_type_node
= gfc_get_int_type (4);
626 /* Start a new block for this statement. */
627 gfc_init_se (&se
, NULL
);
628 gfc_start_block (&se
.pre
);
630 if (code
->expr1
== NULL
)
632 tmp
= build_int_cst (gfc_int4_type_node
, 0);
633 tmp
= build_call_expr_loc (input_location
,
635 ? (flag_coarray
== GFC_FCOARRAY_LIB
636 ? gfor_fndecl_caf_error_stop_str
637 : gfor_fndecl_error_stop_string
)
638 : (flag_coarray
== GFC_FCOARRAY_LIB
639 ? gfor_fndecl_caf_stop_str
640 : gfor_fndecl_stop_string
),
641 2, build_int_cst (pchar_type_node
, 0), tmp
);
643 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
645 gfc_conv_expr (&se
, code
->expr1
);
646 tmp
= build_call_expr_loc (input_location
,
648 ? (flag_coarray
== GFC_FCOARRAY_LIB
649 ? gfor_fndecl_caf_error_stop
650 : gfor_fndecl_error_stop_numeric
)
651 : (flag_coarray
== GFC_FCOARRAY_LIB
652 ? gfor_fndecl_caf_stop_numeric
653 : gfor_fndecl_stop_numeric_f08
), 1,
654 fold_convert (gfc_int4_type_node
, se
.expr
));
658 gfc_conv_expr_reference (&se
, code
->expr1
);
659 tmp
= build_call_expr_loc (input_location
,
661 ? (flag_coarray
== GFC_FCOARRAY_LIB
662 ? gfor_fndecl_caf_error_stop_str
663 : gfor_fndecl_error_stop_string
)
664 : (flag_coarray
== GFC_FCOARRAY_LIB
665 ? gfor_fndecl_caf_stop_str
666 : gfor_fndecl_stop_string
),
667 2, se
.expr
, se
.string_length
);
670 gfc_add_expr_to_block (&se
.pre
, tmp
);
672 gfc_add_block_to_block (&se
.pre
, &se
.post
);
674 return gfc_finish_block (&se
.pre
);
679 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
682 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
683 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
685 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
686 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
687 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
692 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
693 gfc_init_se (&argse
, NULL
);
694 gfc_conv_expr_val (&argse
, code
->expr2
);
697 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
698 stat
= null_pointer_node
;
702 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
703 gfc_init_se (&argse
, NULL
);
704 gfc_conv_expr_val (&argse
, code
->expr4
);
705 lock_acquired
= argse
.expr
;
707 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
708 lock_acquired
= null_pointer_node
;
710 gfc_start_block (&se
.pre
);
711 if (flag_coarray
== GFC_FCOARRAY_LIB
)
713 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
714 tree index
= size_zero_node
;
715 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
717 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
718 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
719 != INTMOD_ISO_FORTRAN_ENV
720 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
721 != ISOFORTRAN_LOCK_TYPE
)
723 gfc_error ("Sorry, the lock component of derived type at %L is not "
724 "yet supported", &code
->expr1
->where
);
728 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
731 if (gfc_is_coindexed (code
->expr1
))
732 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
734 image_index
= integer_zero_node
;
736 /* For arrays, obtain the array index. */
737 if (gfc_expr_attr (code
->expr1
).dimension
)
739 tree desc
, tmp
, extent
, lbound
, ubound
;
740 gfc_array_ref
*ar
, ar2
;
743 /* TODO: Extend this, once DT components are supported. */
744 ar
= &code
->expr1
->ref
->u
.ar
;
746 memset (ar
, '\0', sizeof (*ar
));
750 gfc_init_se (&argse
, NULL
);
751 argse
.descriptor_only
= 1;
752 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
753 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
757 extent
= integer_one_node
;
758 for (i
= 0; i
< ar
->dimen
; i
++)
760 gfc_init_se (&argse
, NULL
);
761 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
762 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
763 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
764 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
765 integer_type_node
, argse
.expr
,
766 fold_convert(integer_type_node
, lbound
));
767 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
768 integer_type_node
, extent
, tmp
);
769 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
770 integer_type_node
, index
, tmp
);
771 if (i
< ar
->dimen
- 1)
773 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
774 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
775 tmp
= fold_convert (integer_type_node
, tmp
);
776 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
777 integer_type_node
, extent
, tmp
);
785 gfc_init_se (&argse
, NULL
);
786 argse
.want_pointer
= 1;
787 gfc_conv_expr (&argse
, code
->expr3
);
788 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
790 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
794 errmsg
= null_pointer_node
;
795 errmsg_len
= integer_zero_node
;
798 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
801 stat
= gfc_create_var (integer_type_node
, "stat");
804 if (lock_acquired
!= null_pointer_node
805 && TREE_TYPE (lock_acquired
) != integer_type_node
)
807 lock_acquired2
= lock_acquired
;
808 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
812 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
813 token
, index
, image_index
,
814 lock_acquired
!= null_pointer_node
815 ? gfc_build_addr_expr (NULL
, lock_acquired
)
817 stat
!= null_pointer_node
818 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
821 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
822 token
, index
, image_index
,
823 stat
!= null_pointer_node
824 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
826 gfc_add_expr_to_block (&se
.pre
, tmp
);
828 /* It guarantees memory consistency within the same segment */
829 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
830 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
831 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
832 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
833 ASM_VOLATILE_P (tmp
) = 1;
835 gfc_add_expr_to_block (&se
.pre
, tmp
);
837 if (stat2
!= NULL_TREE
)
838 gfc_add_modify (&se
.pre
, stat2
,
839 fold_convert (TREE_TYPE (stat2
), stat
));
841 if (lock_acquired2
!= NULL_TREE
)
842 gfc_add_modify (&se
.pre
, lock_acquired2
,
843 fold_convert (TREE_TYPE (lock_acquired2
),
846 return gfc_finish_block (&se
.pre
);
849 if (stat
!= NULL_TREE
)
850 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
852 if (lock_acquired
!= NULL_TREE
)
853 gfc_add_modify (&se
.pre
, lock_acquired
,
854 fold_convert (TREE_TYPE (lock_acquired
),
857 return gfc_finish_block (&se
.pre
);
861 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
864 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
865 tree until_count
= NULL_TREE
;
869 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
870 gfc_init_se (&argse
, NULL
);
871 gfc_conv_expr_val (&argse
, code
->expr2
);
874 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
875 stat
= null_pointer_node
;
879 gfc_init_se (&argse
, NULL
);
880 gfc_conv_expr_val (&argse
, code
->expr4
);
881 until_count
= fold_convert (integer_type_node
, argse
.expr
);
884 until_count
= integer_one_node
;
886 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
888 gfc_start_block (&se
.pre
);
889 gfc_init_se (&argse
, NULL
);
890 gfc_conv_expr_val (&argse
, code
->expr1
);
892 if (op
== EXEC_EVENT_POST
)
893 gfc_add_modify (&se
.pre
, argse
.expr
,
894 fold_build2_loc (input_location
, PLUS_EXPR
,
895 TREE_TYPE (argse
.expr
), argse
.expr
,
896 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
898 gfc_add_modify (&se
.pre
, argse
.expr
,
899 fold_build2_loc (input_location
, MINUS_EXPR
,
900 TREE_TYPE (argse
.expr
), argse
.expr
,
901 fold_convert (TREE_TYPE (argse
.expr
),
903 if (stat
!= NULL_TREE
)
904 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
906 return gfc_finish_block (&se
.pre
);
909 gfc_start_block (&se
.pre
);
910 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
911 tree index
= size_zero_node
;
912 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
914 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
915 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
916 != INTMOD_ISO_FORTRAN_ENV
917 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
918 != ISOFORTRAN_EVENT_TYPE
)
920 gfc_error ("Sorry, the event component of derived type at %L is not "
921 "yet supported", &code
->expr1
->where
);
925 gfc_init_se (&argse
, NULL
);
926 gfc_get_caf_token_offset (&argse
, &token
, NULL
, caf_decl
, NULL_TREE
,
928 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
930 if (gfc_is_coindexed (code
->expr1
))
931 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
933 image_index
= integer_zero_node
;
935 /* For arrays, obtain the array index. */
936 if (gfc_expr_attr (code
->expr1
).dimension
)
938 tree desc
, tmp
, extent
, lbound
, ubound
;
939 gfc_array_ref
*ar
, ar2
;
942 /* TODO: Extend this, once DT components are supported. */
943 ar
= &code
->expr1
->ref
->u
.ar
;
945 memset (ar
, '\0', sizeof (*ar
));
949 gfc_init_se (&argse
, NULL
);
950 argse
.descriptor_only
= 1;
951 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
952 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
956 extent
= integer_one_node
;
957 for (i
= 0; i
< ar
->dimen
; i
++)
959 gfc_init_se (&argse
, NULL
);
960 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
961 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
962 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
963 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
964 integer_type_node
, argse
.expr
,
965 fold_convert(integer_type_node
, lbound
));
966 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
967 integer_type_node
, extent
, tmp
);
968 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
969 integer_type_node
, index
, tmp
);
970 if (i
< ar
->dimen
- 1)
972 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
973 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
974 tmp
= fold_convert (integer_type_node
, tmp
);
975 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
976 integer_type_node
, extent
, tmp
);
984 gfc_init_se (&argse
, NULL
);
985 argse
.want_pointer
= 1;
986 gfc_conv_expr (&argse
, code
->expr3
);
987 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
989 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
993 errmsg
= null_pointer_node
;
994 errmsg_len
= integer_zero_node
;
997 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
1000 stat
= gfc_create_var (integer_type_node
, "stat");
1003 if (op
== EXEC_EVENT_POST
)
1004 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1005 token
, index
, image_index
,
1006 stat
!= null_pointer_node
1007 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1008 errmsg
, errmsg_len
);
1010 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1011 token
, index
, until_count
,
1012 stat
!= null_pointer_node
1013 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1014 errmsg
, errmsg_len
);
1015 gfc_add_expr_to_block (&se
.pre
, tmp
);
1017 /* It guarantees memory consistency within the same segment */
1018 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1019 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1020 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1021 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1022 ASM_VOLATILE_P (tmp
) = 1;
1023 gfc_add_expr_to_block (&se
.pre
, tmp
);
1025 if (stat2
!= NULL_TREE
)
1026 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1028 return gfc_finish_block (&se
.pre
);
1032 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1036 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1037 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1039 /* Short cut: For single images without bound checking or without STAT=,
1040 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1041 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1042 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1045 gfc_init_se (&se
, NULL
);
1046 gfc_start_block (&se
.pre
);
1048 if (code
->expr1
&& code
->expr1
->rank
== 0)
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr_val (&argse
, code
->expr1
);
1052 images
= argse
.expr
;
1057 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1058 gfc_init_se (&argse
, NULL
);
1059 gfc_conv_expr_val (&argse
, code
->expr2
);
1063 stat
= null_pointer_node
;
1065 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1067 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
1068 gfc_init_se (&argse
, NULL
);
1069 argse
.want_pointer
= 1;
1070 gfc_conv_expr (&argse
, code
->expr3
);
1071 gfc_conv_string_parameter (&argse
);
1072 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1073 errmsglen
= argse
.string_length
;
1075 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1077 errmsg
= null_pointer_node
;
1078 errmsglen
= build_int_cst (integer_type_node
, 0);
1081 /* Check SYNC IMAGES(imageset) for valid image index.
1082 FIXME: Add a check for image-set arrays. */
1083 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1084 && code
->expr1
->rank
== 0)
1087 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1088 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1089 images
, build_int_cst (TREE_TYPE (images
), 1));
1093 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1094 2, integer_zero_node
,
1095 build_int_cst (integer_type_node
, -1));
1096 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1098 cond2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1100 build_int_cst (TREE_TYPE (images
), 1));
1101 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1102 boolean_type_node
, cond
, cond2
);
1104 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1105 &code
->expr1
->where
, "Invalid image number "
1106 "%d in SYNC IMAGES",
1107 fold_convert (integer_type_node
, images
));
1110 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1111 image control statements SYNC IMAGES and SYNC ALL. */
1112 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1114 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1115 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1116 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1117 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1118 ASM_VOLATILE_P (tmp
) = 1;
1119 gfc_add_expr_to_block (&se
.pre
, tmp
);
1122 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1124 /* Set STAT to zero. */
1126 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1128 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1130 /* SYNC ALL => stat == null_pointer_node
1131 SYNC ALL(stat=s) => stat has an integer type
1133 If "stat" has the wrong integer type, use a temp variable of
1134 the right type and later cast the result back into "stat". */
1135 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1137 if (TREE_TYPE (stat
) == integer_type_node
)
1138 stat
= gfc_build_addr_expr (NULL
, stat
);
1140 if(type
== EXEC_SYNC_MEMORY
)
1141 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1142 3, stat
, errmsg
, errmsglen
);
1144 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1145 3, stat
, errmsg
, errmsglen
);
1147 gfc_add_expr_to_block (&se
.pre
, tmp
);
1151 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1153 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1154 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1156 gfc_add_expr_to_block (&se
.pre
, tmp
);
1158 gfc_add_modify (&se
.pre
, stat
,
1159 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1166 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1170 len
= build_int_cst (integer_type_node
, -1);
1171 images
= null_pointer_node
;
1173 else if (code
->expr1
->rank
== 0)
1175 len
= build_int_cst (integer_type_node
, 1);
1176 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1181 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1182 gfc_fatal_error ("Sorry, only support for integer kind %d "
1183 "implemented for image-set at %L",
1184 gfc_c_int_kind
, &code
->expr1
->where
);
1186 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1189 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1190 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1191 tmp
= gfc_get_element_type (tmp
);
1193 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1194 TREE_TYPE (len
), len
,
1195 fold_convert (TREE_TYPE (len
),
1196 TYPE_SIZE_UNIT (tmp
)));
1197 len
= fold_convert (integer_type_node
, len
);
1200 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1201 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1203 If "stat" has the wrong integer type, use a temp variable of
1204 the right type and later cast the result back into "stat". */
1205 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1207 if (TREE_TYPE (stat
) == integer_type_node
)
1208 stat
= gfc_build_addr_expr (NULL
, stat
);
1210 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1211 5, fold_convert (integer_type_node
, len
),
1212 images
, stat
, errmsg
, errmsglen
);
1213 gfc_add_expr_to_block (&se
.pre
, tmp
);
1217 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1219 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1220 5, fold_convert (integer_type_node
, len
),
1221 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1223 gfc_add_expr_to_block (&se
.pre
, tmp
);
1225 gfc_add_modify (&se
.pre
, stat
,
1226 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1230 return gfc_finish_block (&se
.pre
);
1234 /* Generate GENERIC for the IF construct. This function also deals with
1235 the simple IF statement, because the front end translates the IF
1236 statement into an IF construct.
1268 where COND_S is the simplified version of the predicate. PRE_COND_S
1269 are the pre side-effects produced by the translation of the
1271 We need to build the chain recursively otherwise we run into
1272 problems with folding incomplete statements. */
1275 gfc_trans_if_1 (gfc_code
* code
)
1278 tree stmt
, elsestmt
;
1282 /* Check for an unconditional ELSE clause. */
1284 return gfc_trans_code (code
->next
);
1286 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1287 gfc_init_se (&if_se
, NULL
);
1288 gfc_start_block (&if_se
.pre
);
1290 /* Calculate the IF condition expression. */
1291 if (code
->expr1
->where
.lb
)
1293 gfc_save_backend_locus (&saved_loc
);
1294 gfc_set_backend_locus (&code
->expr1
->where
);
1297 gfc_conv_expr_val (&if_se
, code
->expr1
);
1299 if (code
->expr1
->where
.lb
)
1300 gfc_restore_backend_locus (&saved_loc
);
1302 /* Translate the THEN clause. */
1303 stmt
= gfc_trans_code (code
->next
);
1305 /* Translate the ELSE clause. */
1307 elsestmt
= gfc_trans_if_1 (code
->block
);
1309 elsestmt
= build_empty_stmt (input_location
);
1311 /* Build the condition expression and add it to the condition block. */
1312 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1313 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1316 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1318 /* Finish off this statement. */
1319 return gfc_finish_block (&if_se
.pre
);
1323 gfc_trans_if (gfc_code
* code
)
1328 /* Create exit label so it is available for trans'ing the body code. */
1329 exit_label
= gfc_build_label_decl (NULL_TREE
);
1330 code
->exit_label
= exit_label
;
1332 /* Translate the actual code in code->block. */
1333 gfc_init_block (&body
);
1334 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1336 /* Add exit label. */
1337 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1339 return gfc_finish_block (&body
);
1343 /* Translate an arithmetic IF expression.
1345 IF (cond) label1, label2, label3 translates to
1357 An optimized version can be generated in case of equal labels.
1358 E.g., if label1 is equal to label2, we can translate it to
1367 gfc_trans_arithmetic_if (gfc_code
* code
)
1375 /* Start a new block. */
1376 gfc_init_se (&se
, NULL
);
1377 gfc_start_block (&se
.pre
);
1379 /* Pre-evaluate COND. */
1380 gfc_conv_expr_val (&se
, code
->expr1
);
1381 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1383 /* Build something to compare with. */
1384 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1386 if (code
->label1
->value
!= code
->label2
->value
)
1388 /* If (cond < 0) take branch1 else take branch2.
1389 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1390 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1391 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1393 if (code
->label1
->value
!= code
->label3
->value
)
1394 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1397 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1400 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1401 tmp
, branch1
, branch2
);
1404 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1406 if (code
->label1
->value
!= code
->label3
->value
1407 && code
->label2
->value
!= code
->label3
->value
)
1409 /* if (cond <= 0) take branch1 else take branch2. */
1410 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1411 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1413 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1414 tmp
, branch1
, branch2
);
1417 /* Append the COND_EXPR to the evaluation of COND, and return. */
1418 gfc_add_expr_to_block (&se
.pre
, branch1
);
1419 return gfc_finish_block (&se
.pre
);
1423 /* Translate a CRITICAL block. */
1425 gfc_trans_critical (gfc_code
*code
)
1428 tree tmp
, token
= NULL_TREE
;
1430 gfc_start_block (&block
);
1432 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1434 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1435 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1436 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1437 token
, integer_zero_node
, integer_one_node
,
1438 null_pointer_node
, null_pointer_node
,
1439 null_pointer_node
, integer_zero_node
);
1440 gfc_add_expr_to_block (&block
, tmp
);
1442 /* It guarantees memory consistency within the same segment */
1443 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1444 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1445 gfc_build_string_const (1, ""),
1446 NULL_TREE
, NULL_TREE
,
1447 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1449 ASM_VOLATILE_P (tmp
) = 1;
1451 gfc_add_expr_to_block (&block
, tmp
);
1454 tmp
= gfc_trans_code (code
->block
->next
);
1455 gfc_add_expr_to_block (&block
, tmp
);
1457 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1459 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1460 token
, integer_zero_node
, integer_one_node
,
1461 null_pointer_node
, null_pointer_node
,
1463 gfc_add_expr_to_block (&block
, tmp
);
1465 /* It guarantees memory consistency within the same segment */
1466 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1467 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1468 gfc_build_string_const (1, ""),
1469 NULL_TREE
, NULL_TREE
,
1470 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1472 ASM_VOLATILE_P (tmp
) = 1;
1474 gfc_add_expr_to_block (&block
, tmp
);
1477 return gfc_finish_block (&block
);
1481 /* Return true, when the class has a _len component. */
1484 class_has_len_component (gfc_symbol
*sym
)
1486 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1489 if (strcmp (comp
->name
, "_len") == 0)
1497 /* Do proper initialization for ASSOCIATE names. */
1500 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1511 bool need_len_assign
;
1513 gcc_assert (sym
->assoc
);
1514 e
= sym
->assoc
->target
;
1516 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1517 && (gfc_is_class_scalar_expr (e
)
1518 || gfc_is_class_array_ref (e
, NULL
));
1520 unlimited
= UNLIMITED_POLY (e
);
1522 /* Assignments to the string length need to be generated, when
1523 ( sym is a char array or
1524 sym has a _len component)
1525 and the associated expression is unlimited polymorphic, which is
1526 not (yet) correctly in 'unlimited', because for an already associated
1527 BT_DERIVED the u-poly flag is not set, i.e.,
1528 __tmp_CHARACTER_0_1 => w => arg
1529 ^ generated temp ^ from code, the w does not have the u-poly
1530 flag set, where UNLIMITED_POLY(e) expects it. */
1531 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1532 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1533 && (sym
->ts
.type
== BT_CHARACTER
1534 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1535 && class_has_len_component (sym
))));
1536 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1537 to array temporary) for arrays with either unknown shape or if associating
1539 if (sym
->attr
.dimension
&& !class_target
1540 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1544 bool cst_array_ctor
;
1546 desc
= sym
->backend_decl
;
1547 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1548 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1550 /* If association is to an expression, evaluate it and create temporary.
1551 Otherwise, get descriptor of target for pointer assignment. */
1552 gfc_init_se (&se
, NULL
);
1553 if (sym
->assoc
->variable
|| cst_array_ctor
)
1555 se
.direct_byref
= 1;
1560 gfc_conv_expr_descriptor (&se
, e
);
1562 /* If we didn't already do the pointer assignment, set associate-name
1563 descriptor to the one generated for the temporary. */
1564 if (!sym
->assoc
->variable
&& !cst_array_ctor
)
1568 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1570 /* The generated descriptor has lower bound zero (as array
1571 temporary), shift bounds so we get lower bounds of 1. */
1572 for (dim
= 0; dim
< e
->rank
; ++dim
)
1573 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1574 dim
, gfc_index_one_node
);
1577 /* If this is a subreference array pointer associate name use the
1578 associate variable element size for the value of 'span'. */
1579 if (sym
->attr
.subref_array_pointer
)
1581 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1582 tmp
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1583 ? gfc_class_data_get (e
->symtree
->n
.sym
->backend_decl
)
1584 : e
->symtree
->n
.sym
->backend_decl
;
1585 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1586 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1587 gfc_add_modify (&se
.pre
, GFC_DECL_SPAN(desc
), tmp
);
1590 /* Done, register stuff as init / cleanup code. */
1591 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1592 gfc_finish_block (&se
.post
));
1595 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1596 arrays to be assigned directly. */
1597 else if (class_target
&& sym
->attr
.dimension
1598 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1602 gfc_init_se (&se
, NULL
);
1603 se
.descriptor_only
= 1;
1604 /* In a select type the (temporary) associate variable shall point to
1605 a standard fortran array (lower bound == 1), but conv_expr ()
1606 just maps to the input array in the class object, whose lbound may
1607 be arbitrary. conv_expr_descriptor solves this by inserting a
1608 temporary array descriptor. */
1609 gfc_conv_expr_descriptor (&se
, e
);
1611 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1612 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1613 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1615 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1617 if (INDIRECT_REF_P (se
.expr
))
1618 tmp
= TREE_OPERAND (se
.expr
, 0);
1622 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1623 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1626 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1630 /* Recover the dtype, which has been overwritten by the
1631 assignment from an unlimited polymorphic object. */
1632 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1633 gfc_add_modify (&se
.pre
, tmp
,
1634 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1637 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1638 gfc_finish_block (&se
.post
));
1641 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1642 else if (gfc_is_associate_pointer (sym
))
1646 gcc_assert (!sym
->attr
.dimension
);
1648 gfc_init_se (&se
, NULL
);
1650 /* Class associate-names come this way because they are
1651 unconditionally associate pointers and the symbol is scalar. */
1652 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1655 /* For a class array we need a descriptor for the selector. */
1656 gfc_conv_expr_descriptor (&se
, e
);
1657 /* Needed to get/set the _len component below. */
1658 target_expr
= se
.expr
;
1660 /* Obtain a temporary class container for the result. */
1661 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1662 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1664 /* Set the offset. */
1665 desc
= gfc_class_data_get (se
.expr
);
1666 offset
= gfc_index_zero_node
;
1667 for (n
= 0; n
< e
->rank
; n
++)
1669 dim
= gfc_rank_cst
[n
];
1670 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1671 gfc_array_index_type
,
1672 gfc_conv_descriptor_stride_get (desc
, dim
),
1673 gfc_conv_descriptor_lbound_get (desc
, dim
));
1674 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1675 gfc_array_index_type
,
1678 if (need_len_assign
)
1681 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1682 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1683 /* Use the original class descriptor stored in the saved
1684 descriptor to get the target_expr. */
1686 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1688 /* Strip the _data component from the target_expr. */
1689 target_expr
= TREE_OPERAND (target_expr
, 0);
1690 /* Add a reference to the _len comp to the target expr. */
1691 tmp
= gfc_class_len_get (target_expr
);
1692 /* Get the component-ref for the temp structure's _len comp. */
1693 charlen
= gfc_class_len_get (se
.expr
);
1694 /* Add the assign to the beginning of the block... */
1695 gfc_add_modify (&se
.pre
, charlen
,
1696 fold_convert (TREE_TYPE (charlen
), tmp
));
1697 /* and the oposite way at the end of the block, to hand changes
1698 on the string length back. */
1699 gfc_add_modify (&se
.post
, tmp
,
1700 fold_convert (TREE_TYPE (tmp
), charlen
));
1701 /* Length assignment done, prevent adding it again below. */
1702 need_len_assign
= false;
1704 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1706 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1707 && CLASS_DATA (e
)->attr
.dimension
)
1709 /* This is bound to be a class array element. */
1710 gfc_conv_expr_reference (&se
, e
);
1711 /* Get the _vptr component of the class object. */
1712 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1713 /* Obtain a temporary class container for the result. */
1714 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1715 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1719 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1720 which has the string length included. For CHARACTERS it is still
1721 needed and will be done at the end of this routine. */
1722 gfc_conv_expr (&se
, e
);
1723 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1726 tmp
= TREE_TYPE (sym
->backend_decl
);
1727 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1728 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1730 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1731 gfc_finish_block (&se
.post
));
1734 /* Do a simple assignment. This is for scalar expressions, where we
1735 can simply use expression assignment. */
1740 lhs
= gfc_lval_expr_from_sym (sym
);
1741 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1742 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1745 /* Set the stringlength, when needed. */
1746 if (need_len_assign
)
1749 gfc_init_se (&se
, NULL
);
1750 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1752 /* What about deferred strings? */
1753 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1754 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1757 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1758 gfc_get_symbol_decl (sym
);
1759 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1760 : gfc_class_len_get (sym
->backend_decl
);
1761 /* Prevent adding a noop len= len. */
1764 gfc_add_modify (&se
.pre
, charlen
,
1765 fold_convert (TREE_TYPE (charlen
), tmp
));
1766 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1767 gfc_finish_block (&se
.post
));
1773 /* Translate a BLOCK construct. This is basically what we would do for a
1777 gfc_trans_block_construct (gfc_code
* code
)
1781 gfc_wrapped_block block
;
1784 gfc_association_list
*ass
;
1786 ns
= code
->ext
.block
.ns
;
1788 sym
= ns
->proc_name
;
1791 /* Process local variables. */
1792 gcc_assert (!sym
->tlink
);
1794 gfc_process_block_locals (ns
);
1796 /* Generate code including exit-label. */
1797 gfc_init_block (&body
);
1798 exit_label
= gfc_build_label_decl (NULL_TREE
);
1799 code
->exit_label
= exit_label
;
1801 finish_oacc_declare (ns
, sym
, true);
1803 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1804 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1806 /* Finish everything. */
1807 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1808 gfc_trans_deferred_vars (sym
, &block
);
1809 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1810 trans_associate_var (ass
->st
->n
.sym
, &block
);
1812 return gfc_finish_wrapped_block (&block
);
1815 /* Translate the simple DO construct in a C-style manner.
1816 This is where the loop variable has integer type and step +-1.
1817 Following code will generate infinite loop in case where TO is INT_MAX
1818 (for +1 step) or INT_MIN (for -1 step)
1820 We translate a do loop from:
1822 DO dovar = from, to, step
1828 [Evaluate loop bounds and step]
1840 This helps the optimizers by avoiding the extra pre-header condition and
1841 we save a register as we just compare the updated IV (not a value in
1845 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1846 tree from
, tree to
, tree step
, tree exit_cond
)
1852 tree saved_dovar
= NULL
;
1856 type
= TREE_TYPE (dovar
);
1857 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
1859 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1861 /* Initialize the DO variable: dovar = from. */
1862 gfc_add_modify_loc (loc
, pblock
, dovar
,
1863 fold_convert (TREE_TYPE (dovar
), from
));
1865 /* Save value for do-tinkering checking. */
1866 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1868 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1869 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1872 /* Cycle and exit statements are implemented with gotos. */
1873 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1874 exit_label
= gfc_build_label_decl (NULL_TREE
);
1876 /* Put the labels where they can be found later. See gfc_trans_do(). */
1877 code
->cycle_label
= cycle_label
;
1878 code
->exit_label
= exit_label
;
1881 gfc_start_block (&body
);
1883 /* Exit the loop if there is an I/O result condition or error. */
1886 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1887 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1889 build_empty_stmt (loc
));
1890 gfc_add_expr_to_block (&body
, tmp
);
1893 /* Evaluate the loop condition. */
1894 if (is_step_positive
)
1895 cond
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, dovar
,
1896 fold_convert (type
, to
));
1898 cond
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, dovar
,
1899 fold_convert (type
, to
));
1901 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1903 /* The loop exit. */
1904 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1905 TREE_USED (exit_label
) = 1;
1906 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1907 cond
, tmp
, build_empty_stmt (loc
));
1908 gfc_add_expr_to_block (&body
, tmp
);
1910 /* Check whether the induction variable is equal to INT_MAX
1911 (respectively to INT_MIN). */
1912 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1914 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
1915 : TYPE_MIN_VALUE (type
);
1917 tmp
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
,
1919 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1920 "Loop iterates infinitely");
1923 /* Main loop body. */
1924 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1925 gfc_add_expr_to_block (&body
, tmp
);
1927 /* Label for cycle statements (if needed). */
1928 if (TREE_USED (cycle_label
))
1930 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1931 gfc_add_expr_to_block (&body
, tmp
);
1934 /* Check whether someone has modified the loop variable. */
1935 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1937 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
1938 dovar
, saved_dovar
);
1939 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1940 "Loop variable has been modified");
1943 /* Increment the loop variable. */
1944 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1945 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1947 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1948 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1950 /* Finish the loop body. */
1951 tmp
= gfc_finish_block (&body
);
1952 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1954 gfc_add_expr_to_block (pblock
, tmp
);
1956 /* Add the exit label. */
1957 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1958 gfc_add_expr_to_block (pblock
, tmp
);
1960 return gfc_finish_block (pblock
);
1963 /* Translate the DO construct. This obviously is one of the most
1964 important ones to get right with any compiler, but especially
1967 We special case some loop forms as described in gfc_trans_simple_do.
1968 For other cases we implement them with a separate loop count,
1969 as described in the standard.
1971 We translate a do loop from:
1973 DO dovar = from, to, step
1979 [evaluate loop bounds and step]
1980 empty = (step > 0 ? to < from : to > from);
1981 countm1 = (to - from) / step;
1983 if (empty) goto exit_label;
1991 if (countm1t == 0) goto exit_label;
1995 countm1 is an unsigned integer. It is equal to the loop count minus one,
1996 because the loop count itself can overflow. */
1999 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2003 tree saved_dovar
= NULL
;
2018 gfc_start_block (&block
);
2020 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2022 /* Evaluate all the expressions in the iterator. */
2023 gfc_init_se (&se
, NULL
);
2024 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2025 gfc_add_block_to_block (&block
, &se
.pre
);
2027 type
= TREE_TYPE (dovar
);
2029 gfc_init_se (&se
, NULL
);
2030 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2031 gfc_add_block_to_block (&block
, &se
.pre
);
2032 from
= gfc_evaluate_now (se
.expr
, &block
);
2034 gfc_init_se (&se
, NULL
);
2035 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2036 gfc_add_block_to_block (&block
, &se
.pre
);
2037 to
= gfc_evaluate_now (se
.expr
, &block
);
2039 gfc_init_se (&se
, NULL
);
2040 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2041 gfc_add_block_to_block (&block
, &se
.pre
);
2042 step
= gfc_evaluate_now (se
.expr
, &block
);
2044 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2046 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
2047 build_zero_cst (type
));
2048 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2049 "DO step value is zero");
2052 /* Special case simple loops. */
2053 if (TREE_CODE (type
) == INTEGER_TYPE
2054 && (integer_onep (step
)
2055 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2056 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2059 if (TREE_CODE (type
) == INTEGER_TYPE
)
2060 utype
= unsigned_type_for (type
);
2062 utype
= unsigned_type_for (gfc_array_index_type
);
2063 countm1
= gfc_create_var (utype
, "countm1");
2065 /* Cycle and exit statements are implemented with gotos. */
2066 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2067 exit_label
= gfc_build_label_decl (NULL_TREE
);
2068 TREE_USED (exit_label
) = 1;
2070 /* Put these labels where they can be found later. */
2071 code
->cycle_label
= cycle_label
;
2072 code
->exit_label
= exit_label
;
2074 /* Initialize the DO variable: dovar = from. */
2075 gfc_add_modify (&block
, dovar
, from
);
2077 /* Save value for do-tinkering checking. */
2078 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2080 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2081 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2084 /* Initialize loop count and jump to exit label if the loop is empty.
2085 This code is executed before we enter the loop body. We generate:
2088 countm1 = (to - from) / step;
2094 countm1 = (from - to) / -step;
2100 if (TREE_CODE (type
) == INTEGER_TYPE
)
2102 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2104 /* The distance from FROM to TO cannot always be represented in a signed
2105 type, thus use unsigned arithmetic, also to avoid any undefined
2107 tou
= fold_convert (utype
, to
);
2108 fromu
= fold_convert (utype
, from
);
2109 stepu
= fold_convert (utype
, step
);
2111 /* For a positive step, when to < from, exit, otherwise compute
2112 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2113 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
2114 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2115 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2118 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2119 fold_build2 (MODIFY_EXPR
, void_type_node
,
2121 build3_loc (loc
, COND_EXPR
, void_type_node
,
2122 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2123 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2124 exit_label
), NULL_TREE
));
2126 /* For a negative step, when to > from, exit, otherwise compute
2127 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2128 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
2129 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2130 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2132 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2133 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2134 fold_build2 (MODIFY_EXPR
, void_type_node
,
2136 build3_loc (loc
, COND_EXPR
, void_type_node
,
2137 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2138 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2139 exit_label
), NULL_TREE
));
2141 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
2142 build_int_cst (TREE_TYPE (step
), 0));
2143 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2145 gfc_add_expr_to_block (&block
, tmp
);
2151 /* TODO: We could use the same width as the real type.
2152 This would probably cause more problems that it solves
2153 when we implement "long double" types. */
2155 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2156 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2157 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2158 gfc_add_modify (&block
, countm1
, tmp
);
2160 /* We need a special check for empty loops:
2161 empty = (step > 0 ? to < from : to > from); */
2162 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
2163 build_zero_cst (type
));
2164 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
2165 fold_build2_loc (loc
, LT_EXPR
,
2166 boolean_type_node
, to
, from
),
2167 fold_build2_loc (loc
, GT_EXPR
,
2168 boolean_type_node
, to
, from
));
2169 /* If the loop is empty, go directly to the exit label. */
2170 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2171 build1_v (GOTO_EXPR
, exit_label
),
2172 build_empty_stmt (input_location
));
2173 gfc_add_expr_to_block (&block
, tmp
);
2177 gfc_start_block (&body
);
2179 /* Main loop body. */
2180 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2181 gfc_add_expr_to_block (&body
, tmp
);
2183 /* Label for cycle statements (if needed). */
2184 if (TREE_USED (cycle_label
))
2186 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2187 gfc_add_expr_to_block (&body
, tmp
);
2190 /* Check whether someone has modified the loop variable. */
2191 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2193 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
2195 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2196 "Loop variable has been modified");
2199 /* Exit the loop if there is an I/O result condition or error. */
2202 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2203 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2205 build_empty_stmt (input_location
));
2206 gfc_add_expr_to_block (&body
, tmp
);
2209 /* Increment the loop variable. */
2210 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2211 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2213 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2214 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2216 /* Initialize countm1t. */
2217 tree countm1t
= gfc_create_var (utype
, "countm1t");
2218 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2220 /* Decrement the loop count. */
2221 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2222 build_int_cst (utype
, 1));
2223 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2225 /* End with the loop condition. Loop until countm1t == 0. */
2226 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
2227 build_int_cst (utype
, 0));
2228 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2229 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2230 cond
, tmp
, build_empty_stmt (loc
));
2231 gfc_add_expr_to_block (&body
, tmp
);
2233 /* End of loop body. */
2234 tmp
= gfc_finish_block (&body
);
2236 /* The for loop itself. */
2237 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2238 gfc_add_expr_to_block (&block
, tmp
);
2240 /* Add the exit label. */
2241 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2242 gfc_add_expr_to_block (&block
, tmp
);
2244 return gfc_finish_block (&block
);
2248 /* Translate the DO WHILE construct.
2261 if (! cond) goto exit_label;
2267 Because the evaluation of the exit condition `cond' may have side
2268 effects, we can't do much for empty loop bodies. The backend optimizers
2269 should be smart enough to eliminate any dead loops. */
2272 gfc_trans_do_while (gfc_code
* code
)
2280 /* Everything we build here is part of the loop body. */
2281 gfc_start_block (&block
);
2283 /* Cycle and exit statements are implemented with gotos. */
2284 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2285 exit_label
= gfc_build_label_decl (NULL_TREE
);
2287 /* Put the labels where they can be found later. See gfc_trans_do(). */
2288 code
->cycle_label
= cycle_label
;
2289 code
->exit_label
= exit_label
;
2291 /* Create a GIMPLE version of the exit condition. */
2292 gfc_init_se (&cond
, NULL
);
2293 gfc_conv_expr_val (&cond
, code
->expr1
);
2294 gfc_add_block_to_block (&block
, &cond
.pre
);
2295 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2296 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2298 /* Build "IF (! cond) GOTO exit_label". */
2299 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2300 TREE_USED (exit_label
) = 1;
2301 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2302 void_type_node
, cond
.expr
, tmp
,
2303 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2304 gfc_add_expr_to_block (&block
, tmp
);
2306 /* The main body of the loop. */
2307 tmp
= gfc_trans_code (code
->block
->next
);
2308 gfc_add_expr_to_block (&block
, tmp
);
2310 /* Label for cycle statements (if needed). */
2311 if (TREE_USED (cycle_label
))
2313 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2314 gfc_add_expr_to_block (&block
, tmp
);
2317 /* End of loop body. */
2318 tmp
= gfc_finish_block (&block
);
2320 gfc_init_block (&block
);
2321 /* Build the loop. */
2322 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2323 void_type_node
, tmp
);
2324 gfc_add_expr_to_block (&block
, tmp
);
2326 /* Add the exit label. */
2327 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2328 gfc_add_expr_to_block (&block
, tmp
);
2330 return gfc_finish_block (&block
);
2334 /* Translate the SELECT CASE construct for INTEGER case expressions,
2335 without killing all potential optimizations. The problem is that
2336 Fortran allows unbounded cases, but the back-end does not, so we
2337 need to intercept those before we enter the equivalent SWITCH_EXPR
2340 For example, we translate this,
2343 CASE (:100,101,105:115)
2353 to the GENERIC equivalent,
2357 case (minimum value for typeof(expr) ... 100:
2363 case 200 ... (maximum value for typeof(expr):
2380 gfc_trans_integer_select (gfc_code
* code
)
2390 gfc_start_block (&block
);
2392 /* Calculate the switch expression. */
2393 gfc_init_se (&se
, NULL
);
2394 gfc_conv_expr_val (&se
, code
->expr1
);
2395 gfc_add_block_to_block (&block
, &se
.pre
);
2397 end_label
= gfc_build_label_decl (NULL_TREE
);
2399 gfc_init_block (&body
);
2401 for (c
= code
->block
; c
; c
= c
->block
)
2403 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2408 /* Assume it's the default case. */
2409 low
= high
= NULL_TREE
;
2413 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2416 /* If there's only a lower bound, set the high bound to the
2417 maximum value of the case expression. */
2419 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2424 /* Three cases are possible here:
2426 1) There is no lower bound, e.g. CASE (:N).
2427 2) There is a lower bound .NE. high bound, that is
2428 a case range, e.g. CASE (N:M) where M>N (we make
2429 sure that M>N during type resolution).
2430 3) There is a lower bound, and it has the same value
2431 as the high bound, e.g. CASE (N:N). This is our
2432 internal representation of CASE(N).
2434 In the first and second case, we need to set a value for
2435 high. In the third case, we don't because the GCC middle
2436 end represents a single case value by just letting high be
2437 a NULL_TREE. We can't do that because we need to be able
2438 to represent unbounded cases. */
2442 && mpz_cmp (cp
->low
->value
.integer
,
2443 cp
->high
->value
.integer
) != 0))
2444 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2447 /* Unbounded case. */
2449 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2452 /* Build a label. */
2453 label
= gfc_build_label_decl (NULL_TREE
);
2455 /* Add this case label.
2456 Add parameter 'label', make it match GCC backend. */
2457 tmp
= build_case_label (low
, high
, label
);
2458 gfc_add_expr_to_block (&body
, tmp
);
2461 /* Add the statements for this case. */
2462 tmp
= gfc_trans_code (c
->next
);
2463 gfc_add_expr_to_block (&body
, tmp
);
2465 /* Break to the end of the construct. */
2466 tmp
= build1_v (GOTO_EXPR
, end_label
);
2467 gfc_add_expr_to_block (&body
, tmp
);
2470 tmp
= gfc_finish_block (&body
);
2471 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2472 se
.expr
, tmp
, NULL_TREE
);
2473 gfc_add_expr_to_block (&block
, tmp
);
2475 tmp
= build1_v (LABEL_EXPR
, end_label
);
2476 gfc_add_expr_to_block (&block
, tmp
);
2478 return gfc_finish_block (&block
);
2482 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2484 There are only two cases possible here, even though the standard
2485 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2486 .FALSE., and DEFAULT.
2488 We never generate more than two blocks here. Instead, we always
2489 try to eliminate the DEFAULT case. This way, we can translate this
2490 kind of SELECT construct to a simple
2494 expression in GENERIC. */
2497 gfc_trans_logical_select (gfc_code
* code
)
2500 gfc_code
*t
, *f
, *d
;
2505 /* Assume we don't have any cases at all. */
2508 /* Now see which ones we actually do have. We can have at most two
2509 cases in a single case list: one for .TRUE. and one for .FALSE.
2510 The default case is always separate. If the cases for .TRUE. and
2511 .FALSE. are in the same case list, the block for that case list
2512 always executed, and we don't generate code a COND_EXPR. */
2513 for (c
= code
->block
; c
; c
= c
->block
)
2515 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2519 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2521 else /* if (cp->value.logical != 0), thus .TRUE. */
2529 /* Start a new block. */
2530 gfc_start_block (&block
);
2532 /* Calculate the switch expression. We always need to do this
2533 because it may have side effects. */
2534 gfc_init_se (&se
, NULL
);
2535 gfc_conv_expr_val (&se
, code
->expr1
);
2536 gfc_add_block_to_block (&block
, &se
.pre
);
2538 if (t
== f
&& t
!= NULL
)
2540 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2541 translate the code for these cases, append it to the current
2543 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2547 tree true_tree
, false_tree
, stmt
;
2549 true_tree
= build_empty_stmt (input_location
);
2550 false_tree
= build_empty_stmt (input_location
);
2552 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2553 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2554 make the missing case the default case. */
2555 if (t
!= NULL
&& f
!= NULL
)
2565 /* Translate the code for each of these blocks, and append it to
2566 the current block. */
2568 true_tree
= gfc_trans_code (t
->next
);
2571 false_tree
= gfc_trans_code (f
->next
);
2573 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2574 se
.expr
, true_tree
, false_tree
);
2575 gfc_add_expr_to_block (&block
, stmt
);
2578 return gfc_finish_block (&block
);
2582 /* The jump table types are stored in static variables to avoid
2583 constructing them from scratch every single time. */
2584 static GTY(()) tree select_struct
[2];
2586 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2587 Instead of generating compares and jumps, it is far simpler to
2588 generate a data structure describing the cases in order and call a
2589 library subroutine that locates the right case.
2590 This is particularly true because this is the only case where we
2591 might have to dispose of a temporary.
2592 The library subroutine returns a pointer to jump to or NULL if no
2593 branches are to be taken. */
2596 gfc_trans_character_select (gfc_code
*code
)
2598 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2599 stmtblock_t block
, body
;
2604 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2606 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2608 /* The jump table types are stored in static variables to avoid
2609 constructing them from scratch every single time. */
2610 static tree ss_string1
[2], ss_string1_len
[2];
2611 static tree ss_string2
[2], ss_string2_len
[2];
2612 static tree ss_target
[2];
2614 cp
= code
->block
->ext
.block
.case_list
;
2615 while (cp
->left
!= NULL
)
2618 /* Generate the body */
2619 gfc_start_block (&block
);
2620 gfc_init_se (&expr1se
, NULL
);
2621 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2623 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2625 end_label
= gfc_build_label_decl (NULL_TREE
);
2627 gfc_init_block (&body
);
2629 /* Attempt to optimize length 1 selects. */
2630 if (integer_onep (expr1se
.string_length
))
2632 for (d
= cp
; d
; d
= d
->right
)
2637 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2638 && d
->low
->ts
.type
== BT_CHARACTER
);
2639 if (d
->low
->value
.character
.length
> 1)
2641 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2642 if (d
->low
->value
.character
.string
[i
] != ' ')
2644 if (i
!= d
->low
->value
.character
.length
)
2646 if (optimize
&& d
->high
&& i
== 1)
2648 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2649 && d
->high
->ts
.type
== BT_CHARACTER
);
2650 if (d
->high
->value
.character
.length
> 1
2651 && (d
->low
->value
.character
.string
[0]
2652 == d
->high
->value
.character
.string
[0])
2653 && d
->high
->value
.character
.string
[1] != ' '
2654 && ((d
->low
->value
.character
.string
[1] < ' ')
2655 == (d
->high
->value
.character
.string
[1]
2665 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2666 && d
->high
->ts
.type
== BT_CHARACTER
);
2667 if (d
->high
->value
.character
.length
> 1)
2669 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2670 if (d
->high
->value
.character
.string
[i
] != ' ')
2672 if (i
!= d
->high
->value
.character
.length
)
2679 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2681 for (c
= code
->block
; c
; c
= c
->block
)
2683 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2689 /* Assume it's the default case. */
2690 low
= high
= NULL_TREE
;
2694 /* CASE ('ab') or CASE ('ab':'az') will never match
2695 any length 1 character. */
2696 if (cp
->low
->value
.character
.length
> 1
2697 && cp
->low
->value
.character
.string
[1] != ' ')
2700 if (cp
->low
->value
.character
.length
> 0)
2701 r
= cp
->low
->value
.character
.string
[0];
2704 low
= build_int_cst (ctype
, r
);
2706 /* If there's only a lower bound, set the high bound
2707 to the maximum value of the case expression. */
2709 high
= TYPE_MAX_VALUE (ctype
);
2715 || (cp
->low
->value
.character
.string
[0]
2716 != cp
->high
->value
.character
.string
[0]))
2718 if (cp
->high
->value
.character
.length
> 0)
2719 r
= cp
->high
->value
.character
.string
[0];
2722 high
= build_int_cst (ctype
, r
);
2725 /* Unbounded case. */
2727 low
= TYPE_MIN_VALUE (ctype
);
2730 /* Build a label. */
2731 label
= gfc_build_label_decl (NULL_TREE
);
2733 /* Add this case label.
2734 Add parameter 'label', make it match GCC backend. */
2735 tmp
= build_case_label (low
, high
, label
);
2736 gfc_add_expr_to_block (&body
, tmp
);
2739 /* Add the statements for this case. */
2740 tmp
= gfc_trans_code (c
->next
);
2741 gfc_add_expr_to_block (&body
, tmp
);
2743 /* Break to the end of the construct. */
2744 tmp
= build1_v (GOTO_EXPR
, end_label
);
2745 gfc_add_expr_to_block (&body
, tmp
);
2748 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2750 code
->expr1
->ts
.kind
);
2751 case_num
= gfc_create_var (ctype
, "case_num");
2752 gfc_add_modify (&block
, case_num
, tmp
);
2754 gfc_add_block_to_block (&block
, &expr1se
.post
);
2756 tmp
= gfc_finish_block (&body
);
2757 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2758 case_num
, tmp
, NULL_TREE
);
2759 gfc_add_expr_to_block (&block
, tmp
);
2761 tmp
= build1_v (LABEL_EXPR
, end_label
);
2762 gfc_add_expr_to_block (&block
, tmp
);
2764 return gfc_finish_block (&block
);
2768 if (code
->expr1
->ts
.kind
== 1)
2770 else if (code
->expr1
->ts
.kind
== 4)
2775 if (select_struct
[k
] == NULL
)
2778 select_struct
[k
] = make_node (RECORD_TYPE
);
2780 if (code
->expr1
->ts
.kind
== 1)
2781 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2782 else if (code
->expr1
->ts
.kind
== 4)
2783 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2788 #define ADD_FIELD(NAME, TYPE) \
2789 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2790 get_identifier (stringize(NAME)), \
2794 ADD_FIELD (string1
, pchartype
);
2795 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2797 ADD_FIELD (string2
, pchartype
);
2798 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2800 ADD_FIELD (target
, integer_type_node
);
2803 gfc_finish_type (select_struct
[k
]);
2807 for (d
= cp
; d
; d
= d
->right
)
2810 for (c
= code
->block
; c
; c
= c
->block
)
2812 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
2814 label
= gfc_build_label_decl (NULL_TREE
);
2815 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
2817 : build_int_cst (integer_type_node
, d
->n
),
2819 gfc_add_expr_to_block (&body
, tmp
);
2822 tmp
= gfc_trans_code (c
->next
);
2823 gfc_add_expr_to_block (&body
, tmp
);
2825 tmp
= build1_v (GOTO_EXPR
, end_label
);
2826 gfc_add_expr_to_block (&body
, tmp
);
2829 /* Generate the structure describing the branches */
2830 for (d
= cp
; d
; d
= d
->right
)
2832 vec
<constructor_elt
, va_gc
> *node
= NULL
;
2834 gfc_init_se (&se
, NULL
);
2838 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
2839 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
2843 gfc_conv_expr_reference (&se
, d
->low
);
2845 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
2846 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
2849 if (d
->high
== NULL
)
2851 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
2852 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
2856 gfc_init_se (&se
, NULL
);
2857 gfc_conv_expr_reference (&se
, d
->high
);
2859 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
2860 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
2863 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
2864 build_int_cst (integer_type_node
, d
->n
));
2866 tmp
= build_constructor (select_struct
[k
], node
);
2867 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
2870 type
= build_array_type (select_struct
[k
],
2871 build_index_type (size_int (n
-1)));
2873 init
= build_constructor (type
, inits
);
2874 TREE_CONSTANT (init
) = 1;
2875 TREE_STATIC (init
) = 1;
2876 /* Create a static variable to hold the jump table. */
2877 tmp
= gfc_create_var (type
, "jumptable");
2878 TREE_CONSTANT (tmp
) = 1;
2879 TREE_STATIC (tmp
) = 1;
2880 TREE_READONLY (tmp
) = 1;
2881 DECL_INITIAL (tmp
) = init
;
2884 /* Build the library call */
2885 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
2887 if (code
->expr1
->ts
.kind
== 1)
2888 fndecl
= gfor_fndecl_select_string
;
2889 else if (code
->expr1
->ts
.kind
== 4)
2890 fndecl
= gfor_fndecl_select_string_char4
;
2894 tmp
= build_call_expr_loc (input_location
,
2896 build_int_cst (gfc_charlen_type_node
, n
),
2897 expr1se
.expr
, expr1se
.string_length
);
2898 case_num
= gfc_create_var (integer_type_node
, "case_num");
2899 gfc_add_modify (&block
, case_num
, tmp
);
2901 gfc_add_block_to_block (&block
, &expr1se
.post
);
2903 tmp
= gfc_finish_block (&body
);
2904 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2905 case_num
, tmp
, NULL_TREE
);
2906 gfc_add_expr_to_block (&block
, tmp
);
2908 tmp
= build1_v (LABEL_EXPR
, end_label
);
2909 gfc_add_expr_to_block (&block
, tmp
);
2911 return gfc_finish_block (&block
);
2915 /* Translate the three variants of the SELECT CASE construct.
2917 SELECT CASEs with INTEGER case expressions can be translated to an
2918 equivalent GENERIC switch statement, and for LOGICAL case
2919 expressions we build one or two if-else compares.
2921 SELECT CASEs with CHARACTER case expressions are a whole different
2922 story, because they don't exist in GENERIC. So we sort them and
2923 do a binary search at runtime.
2925 Fortran has no BREAK statement, and it does not allow jumps from
2926 one case block to another. That makes things a lot easier for
2930 gfc_trans_select (gfc_code
* code
)
2936 gcc_assert (code
&& code
->expr1
);
2937 gfc_init_block (&block
);
2939 /* Build the exit label and hang it in. */
2940 exit_label
= gfc_build_label_decl (NULL_TREE
);
2941 code
->exit_label
= exit_label
;
2943 /* Empty SELECT constructs are legal. */
2944 if (code
->block
== NULL
)
2945 body
= build_empty_stmt (input_location
);
2947 /* Select the correct translation function. */
2949 switch (code
->expr1
->ts
.type
)
2952 body
= gfc_trans_logical_select (code
);
2956 body
= gfc_trans_integer_select (code
);
2960 body
= gfc_trans_character_select (code
);
2964 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2968 /* Build everything together. */
2969 gfc_add_expr_to_block (&block
, body
);
2970 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
2972 return gfc_finish_block (&block
);
2976 /* Traversal function to substitute a replacement symtree if the symbol
2977 in the expression is the same as that passed. f == 2 signals that
2978 that variable itself is not to be checked - only the references.
2979 This group of functions is used when the variable expression in a
2980 FORALL assignment has internal references. For example:
2981 FORALL (i = 1:4) p(p(i)) = i
2982 The only recourse here is to store a copy of 'p' for the index
2985 static gfc_symtree
*new_symtree
;
2986 static gfc_symtree
*old_symtree
;
2989 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
2991 if (expr
->expr_type
!= EXPR_VARIABLE
)
2996 else if (expr
->symtree
->n
.sym
== sym
)
2997 expr
->symtree
= new_symtree
;
3003 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3005 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3009 forall_restore (gfc_expr
*expr
,
3010 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3011 int *f ATTRIBUTE_UNUSED
)
3013 if (expr
->expr_type
!= EXPR_VARIABLE
)
3016 if (expr
->symtree
== new_symtree
)
3017 expr
->symtree
= old_symtree
;
3023 forall_restore_symtree (gfc_expr
*e
)
3025 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3029 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3034 gfc_symbol
*new_sym
;
3035 gfc_symbol
*old_sym
;
3039 /* Build a copy of the lvalue. */
3040 old_symtree
= c
->expr1
->symtree
;
3041 old_sym
= old_symtree
->n
.sym
;
3042 e
= gfc_lval_expr_from_sym (old_sym
);
3043 if (old_sym
->attr
.dimension
)
3045 gfc_init_se (&tse
, NULL
);
3046 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3047 gfc_add_block_to_block (pre
, &tse
.pre
);
3048 gfc_add_block_to_block (post
, &tse
.post
);
3049 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3051 if (e
->ts
.type
!= BT_CHARACTER
)
3053 /* Use the variable offset for the temporary. */
3054 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3055 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3060 gfc_init_se (&tse
, NULL
);
3061 gfc_init_se (&rse
, NULL
);
3062 gfc_conv_expr (&rse
, e
);
3063 if (e
->ts
.type
== BT_CHARACTER
)
3065 tse
.string_length
= rse
.string_length
;
3066 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3068 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3070 gfc_add_block_to_block (pre
, &tse
.pre
);
3071 gfc_add_block_to_block (post
, &tse
.post
);
3075 tmp
= gfc_typenode_for_spec (&e
->ts
);
3076 tse
.expr
= gfc_create_var (tmp
, "temp");
3079 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3080 e
->expr_type
== EXPR_VARIABLE
, false);
3081 gfc_add_expr_to_block (pre
, tmp
);
3085 /* Create a new symbol to represent the lvalue. */
3086 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3087 new_sym
->ts
= old_sym
->ts
;
3088 new_sym
->attr
.referenced
= 1;
3089 new_sym
->attr
.temporary
= 1;
3090 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3091 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3093 /* Use the temporary as the backend_decl. */
3094 new_sym
->backend_decl
= tse
.expr
;
3096 /* Create a fake symtree for it. */
3098 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3099 new_symtree
->n
.sym
= new_sym
;
3100 gcc_assert (new_symtree
== root
);
3102 /* Go through the expression reference replacing the old_symtree
3104 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3106 /* Now we have made this temporary, we might as well use it for
3107 the right hand side. */
3108 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3112 /* Handles dependencies in forall assignments. */
3114 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3121 lsym
= c
->expr1
->symtree
->n
.sym
;
3122 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3124 /* Now check for dependencies within the 'variable'
3125 expression itself. These are treated by making a complete
3126 copy of variable and changing all the references to it
3127 point to the copy instead. Note that the shallow copy of
3128 the variable will not suffice for derived types with
3129 pointer components. We therefore leave these to their
3131 if (lsym
->ts
.type
== BT_DERIVED
3132 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3136 if (find_forall_index (c
->expr1
, lsym
, 2))
3138 forall_make_variable_temp (c
, pre
, post
);
3142 /* Substrings with dependencies are treated in the same
3144 if (c
->expr1
->ts
.type
== BT_CHARACTER
3146 && c
->expr2
->expr_type
== EXPR_VARIABLE
3147 && lsym
== c
->expr2
->symtree
->n
.sym
)
3149 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3150 if (lref
->type
== REF_SUBSTRING
)
3152 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3153 if (rref
->type
== REF_SUBSTRING
)
3157 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3159 forall_make_variable_temp (c
, pre
, post
);
3168 cleanup_forall_symtrees (gfc_code
*c
)
3170 forall_restore_symtree (c
->expr1
);
3171 forall_restore_symtree (c
->expr2
);
3172 free (new_symtree
->n
.sym
);
3177 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3178 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3179 indicates whether we should generate code to test the FORALLs mask
3180 array. OUTER is the loop header to be used for initializing mask
3183 The generated loop format is:
3184 count = (end - start + step) / step
3197 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3198 int mask_flag
, stmtblock_t
*outer
)
3206 tree var
, start
, end
, step
;
3209 /* Initialize the mask index outside the FORALL nest. */
3210 if (mask_flag
&& forall_tmp
->mask
)
3211 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3213 iter
= forall_tmp
->this_loop
;
3214 nvar
= forall_tmp
->nvar
;
3215 for (n
= 0; n
< nvar
; n
++)
3218 start
= iter
->start
;
3222 exit_label
= gfc_build_label_decl (NULL_TREE
);
3223 TREE_USED (exit_label
) = 1;
3225 /* The loop counter. */
3226 count
= gfc_create_var (TREE_TYPE (var
), "count");
3228 /* The body of the loop. */
3229 gfc_init_block (&block
);
3231 /* The exit condition. */
3232 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3233 count
, build_int_cst (TREE_TYPE (count
), 0));
3234 if (forall_tmp
->do_concurrent
)
3235 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3236 build_int_cst (integer_type_node
,
3237 annot_expr_ivdep_kind
));
3239 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3240 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3241 cond
, tmp
, build_empty_stmt (input_location
));
3242 gfc_add_expr_to_block (&block
, tmp
);
3244 /* The main loop body. */
3245 gfc_add_expr_to_block (&block
, body
);
3247 /* Increment the loop variable. */
3248 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3250 gfc_add_modify (&block
, var
, tmp
);
3252 /* Advance to the next mask element. Only do this for the
3254 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3256 tree maskindex
= forall_tmp
->maskindex
;
3257 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3258 maskindex
, gfc_index_one_node
);
3259 gfc_add_modify (&block
, maskindex
, tmp
);
3262 /* Decrement the loop counter. */
3263 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3264 build_int_cst (TREE_TYPE (var
), 1));
3265 gfc_add_modify (&block
, count
, tmp
);
3267 body
= gfc_finish_block (&block
);
3269 /* Loop var initialization. */
3270 gfc_init_block (&block
);
3271 gfc_add_modify (&block
, var
, start
);
3274 /* Initialize the loop counter. */
3275 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3277 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3279 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3281 gfc_add_modify (&block
, count
, tmp
);
3283 /* The loop expression. */
3284 tmp
= build1_v (LOOP_EXPR
, body
);
3285 gfc_add_expr_to_block (&block
, tmp
);
3287 /* The exit label. */
3288 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3289 gfc_add_expr_to_block (&block
, tmp
);
3291 body
= gfc_finish_block (&block
);
3298 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3299 is nonzero, the body is controlled by all masks in the forall nest.
3300 Otherwise, the innermost loop is not controlled by it's mask. This
3301 is used for initializing that mask. */
3304 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3309 forall_info
*forall_tmp
;
3310 tree mask
, maskindex
;
3312 gfc_start_block (&header
);
3314 forall_tmp
= nested_forall_info
;
3315 while (forall_tmp
!= NULL
)
3317 /* Generate body with masks' control. */
3320 mask
= forall_tmp
->mask
;
3321 maskindex
= forall_tmp
->maskindex
;
3323 /* If a mask was specified make the assignment conditional. */
3326 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3327 body
= build3_v (COND_EXPR
, tmp
, body
,
3328 build_empty_stmt (input_location
));
3331 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3332 forall_tmp
= forall_tmp
->prev_nest
;
3336 gfc_add_expr_to_block (&header
, body
);
3337 return gfc_finish_block (&header
);
3341 /* Allocate data for holding a temporary array. Returns either a local
3342 temporary array or a pointer variable. */
3345 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3352 if (INTEGER_CST_P (size
))
3353 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3354 size
, gfc_index_one_node
);
3358 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3359 type
= build_array_type (elem_type
, type
);
3360 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3362 tmpvar
= gfc_create_var (type
, "temp");
3367 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3368 *pdata
= convert (pvoid_type_node
, tmpvar
);
3370 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3371 gfc_add_modify (pblock
, tmpvar
, tmp
);
3377 /* Generate codes to copy the temporary to the actual lhs. */
3380 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3381 tree count1
, tree wheremask
, bool invert
)
3385 stmtblock_t block
, body
;
3391 lss
= gfc_walk_expr (expr
);
3393 if (lss
== gfc_ss_terminator
)
3395 gfc_start_block (&block
);
3397 gfc_init_se (&lse
, NULL
);
3399 /* Translate the expression. */
3400 gfc_conv_expr (&lse
, expr
);
3402 /* Form the expression for the temporary. */
3403 tmp
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3405 /* Use the scalar assignment as is. */
3406 gfc_add_block_to_block (&block
, &lse
.pre
);
3407 gfc_add_modify (&block
, lse
.expr
, tmp
);
3408 gfc_add_block_to_block (&block
, &lse
.post
);
3410 /* Increment the count1. */
3411 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3412 count1
, gfc_index_one_node
);
3413 gfc_add_modify (&block
, count1
, tmp
);
3415 tmp
= gfc_finish_block (&block
);
3419 gfc_start_block (&block
);
3421 gfc_init_loopinfo (&loop1
);
3422 gfc_init_se (&rse
, NULL
);
3423 gfc_init_se (&lse
, NULL
);
3425 /* Associate the lss with the loop. */
3426 gfc_add_ss_to_loop (&loop1
, lss
);
3428 /* Calculate the bounds of the scalarization. */
3429 gfc_conv_ss_startstride (&loop1
);
3430 /* Setup the scalarizing loops. */
3431 gfc_conv_loop_setup (&loop1
, &expr
->where
);
3433 gfc_mark_ss_chain_used (lss
, 1);
3435 /* Start the scalarized loop body. */
3436 gfc_start_scalarized_body (&loop1
, &body
);
3438 /* Setup the gfc_se structures. */
3439 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
3442 /* Form the expression of the temporary. */
3443 if (lss
!= gfc_ss_terminator
)
3444 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3445 /* Translate expr. */
3446 gfc_conv_expr (&lse
, expr
);
3448 /* Use the scalar assignment. */
3449 rse
.string_length
= lse
.string_length
;
3450 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, true);
3452 /* Form the mask expression according to the mask tree list. */
3455 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3457 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3458 TREE_TYPE (wheremaskexpr
),
3460 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3462 build_empty_stmt (input_location
));
3465 gfc_add_expr_to_block (&body
, tmp
);
3467 /* Increment count1. */
3468 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3469 count1
, gfc_index_one_node
);
3470 gfc_add_modify (&body
, count1
, tmp
);
3472 /* Increment count3. */
3475 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3476 gfc_array_index_type
, count3
,
3477 gfc_index_one_node
);
3478 gfc_add_modify (&body
, count3
, tmp
);
3481 /* Generate the copying loops. */
3482 gfc_trans_scalarizing_loops (&loop1
, &body
);
3483 gfc_add_block_to_block (&block
, &loop1
.pre
);
3484 gfc_add_block_to_block (&block
, &loop1
.post
);
3485 gfc_cleanup_loop (&loop1
);
3487 tmp
= gfc_finish_block (&block
);
3493 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3494 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3495 and should not be freed. WHEREMASK is the conditional execution mask
3496 whose sense may be inverted by INVERT. */
3499 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3500 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3501 tree wheremask
, bool invert
)
3503 stmtblock_t block
, body1
;
3510 gfc_start_block (&block
);
3512 gfc_init_se (&rse
, NULL
);
3513 gfc_init_se (&lse
, NULL
);
3515 if (lss
== gfc_ss_terminator
)
3517 gfc_init_block (&body1
);
3518 gfc_conv_expr (&rse
, expr2
);
3519 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3523 /* Initialize the loop. */
3524 gfc_init_loopinfo (&loop
);
3526 /* We may need LSS to determine the shape of the expression. */
3527 gfc_add_ss_to_loop (&loop
, lss
);
3528 gfc_add_ss_to_loop (&loop
, rss
);
3530 gfc_conv_ss_startstride (&loop
);
3531 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3533 gfc_mark_ss_chain_used (rss
, 1);
3534 /* Start the loop body. */
3535 gfc_start_scalarized_body (&loop
, &body1
);
3537 /* Translate the expression. */
3538 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3540 gfc_conv_expr (&rse
, expr2
);
3542 /* Form the expression of the temporary. */
3543 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3546 /* Use the scalar assignment. */
3547 lse
.string_length
= rse
.string_length
;
3548 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3549 expr2
->expr_type
== EXPR_VARIABLE
, false);
3551 /* Form the mask expression according to the mask tree list. */
3554 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3556 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3557 TREE_TYPE (wheremaskexpr
),
3559 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3561 build_empty_stmt (input_location
));
3564 gfc_add_expr_to_block (&body1
, tmp
);
3566 if (lss
== gfc_ss_terminator
)
3568 gfc_add_block_to_block (&block
, &body1
);
3570 /* Increment count1. */
3571 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3572 count1
, gfc_index_one_node
);
3573 gfc_add_modify (&block
, count1
, tmp
);
3577 /* Increment count1. */
3578 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3579 count1
, gfc_index_one_node
);
3580 gfc_add_modify (&body1
, count1
, tmp
);
3582 /* Increment count3. */
3585 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3586 gfc_array_index_type
,
3587 count3
, gfc_index_one_node
);
3588 gfc_add_modify (&body1
, count3
, tmp
);
3591 /* Generate the copying loops. */
3592 gfc_trans_scalarizing_loops (&loop
, &body1
);
3594 gfc_add_block_to_block (&block
, &loop
.pre
);
3595 gfc_add_block_to_block (&block
, &loop
.post
);
3597 gfc_cleanup_loop (&loop
);
3598 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3599 as tree nodes in SS may not be valid in different scope. */
3602 tmp
= gfc_finish_block (&block
);
3607 /* Calculate the size of temporary needed in the assignment inside forall.
3608 LSS and RSS are filled in this function. */
3611 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3612 stmtblock_t
* pblock
,
3613 gfc_ss
**lss
, gfc_ss
**rss
)
3621 *lss
= gfc_walk_expr (expr1
);
3624 size
= gfc_index_one_node
;
3625 if (*lss
!= gfc_ss_terminator
)
3627 gfc_init_loopinfo (&loop
);
3629 /* Walk the RHS of the expression. */
3630 *rss
= gfc_walk_expr (expr2
);
3631 if (*rss
== gfc_ss_terminator
)
3632 /* The rhs is scalar. Add a ss for the expression. */
3633 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3635 /* Associate the SS with the loop. */
3636 gfc_add_ss_to_loop (&loop
, *lss
);
3637 /* We don't actually need to add the rhs at this point, but it might
3638 make guessing the loop bounds a bit easier. */
3639 gfc_add_ss_to_loop (&loop
, *rss
);
3641 /* We only want the shape of the expression, not rest of the junk
3642 generated by the scalarizer. */
3643 loop
.array_parameter
= 1;
3645 /* Calculate the bounds of the scalarization. */
3646 save_flag
= gfc_option
.rtcheck
;
3647 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3648 gfc_conv_ss_startstride (&loop
);
3649 gfc_option
.rtcheck
= save_flag
;
3650 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3652 /* Figure out how many elements we need. */
3653 for (i
= 0; i
< loop
.dimen
; i
++)
3655 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3656 gfc_array_index_type
,
3657 gfc_index_one_node
, loop
.from
[i
]);
3658 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3659 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3660 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3661 gfc_array_index_type
, size
, tmp
);
3663 gfc_add_block_to_block (pblock
, &loop
.pre
);
3664 size
= gfc_evaluate_now (size
, pblock
);
3665 gfc_add_block_to_block (pblock
, &loop
.post
);
3667 /* TODO: write a function that cleans up a loopinfo without freeing
3668 the SS chains. Currently a NOP. */
3675 /* Calculate the overall iterator number of the nested forall construct.
3676 This routine actually calculates the number of times the body of the
3677 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3678 that by the expression INNER_SIZE. The BLOCK argument specifies the
3679 block in which to calculate the result, and the optional INNER_SIZE_BODY
3680 argument contains any statements that need to executed (inside the loop)
3681 to initialize or calculate INNER_SIZE. */
3684 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3685 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3687 forall_info
*forall_tmp
= nested_forall_info
;
3691 /* We can eliminate the innermost unconditional loops with constant
3693 if (INTEGER_CST_P (inner_size
))
3696 && !forall_tmp
->mask
3697 && INTEGER_CST_P (forall_tmp
->size
))
3699 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3700 gfc_array_index_type
,
3701 inner_size
, forall_tmp
->size
);
3702 forall_tmp
= forall_tmp
->prev_nest
;
3705 /* If there are no loops left, we have our constant result. */
3710 /* Otherwise, create a temporary variable to compute the result. */
3711 number
= gfc_create_var (gfc_array_index_type
, "num");
3712 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3714 gfc_start_block (&body
);
3715 if (inner_size_body
)
3716 gfc_add_block_to_block (&body
, inner_size_body
);
3718 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3719 gfc_array_index_type
, number
, inner_size
);
3722 gfc_add_modify (&body
, number
, tmp
);
3723 tmp
= gfc_finish_block (&body
);
3725 /* Generate loops. */
3726 if (forall_tmp
!= NULL
)
3727 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3729 gfc_add_expr_to_block (block
, tmp
);
3735 /* Allocate temporary for forall construct. SIZE is the size of temporary
3736 needed. PTEMP1 is returned for space free. */
3739 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3746 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3747 if (!integer_onep (unit
))
3748 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3749 gfc_array_index_type
, size
, unit
);
3754 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3757 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3762 /* Allocate temporary for forall construct according to the information in
3763 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3764 assignment inside forall. PTEMP1 is returned for space free. */
3767 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3768 tree inner_size
, stmtblock_t
* inner_size_body
,
3769 stmtblock_t
* block
, tree
* ptemp1
)
3773 /* Calculate the total size of temporary needed in forall construct. */
3774 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3775 inner_size_body
, block
);
3777 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3781 /* Handle assignments inside forall which need temporary.
3783 forall (i=start:end:stride; maskexpr)
3786 (where e,f<i> are arbitrary expressions possibly involving i
3787 and there is a dependency between e<i> and f<i>)
3789 masktmp(:) = maskexpr(:)
3794 for (i = start; i <= end; i += stride)
3798 for (i = start; i <= end; i += stride)
3800 if (masktmp[maskindex++])
3801 tmp[count1++] = f<i>
3805 for (i = start; i <= end; i += stride)
3807 if (masktmp[maskindex++])
3808 e<i> = tmp[count1++]
3813 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3814 tree wheremask
, bool invert
,
3815 forall_info
* nested_forall_info
,
3816 stmtblock_t
* block
)
3824 stmtblock_t inner_size_body
;
3826 /* Create vars. count1 is the current iterator number of the nested
3828 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3830 /* Count is the wheremask index. */
3833 count
= gfc_create_var (gfc_array_index_type
, "count");
3834 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3839 /* Initialize count1. */
3840 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3842 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3843 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3844 gfc_init_block (&inner_size_body
);
3845 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
3848 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3849 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->length
)
3851 if (!expr1
->ts
.u
.cl
->backend_decl
)
3854 gfc_init_se (&tse
, NULL
);
3855 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
3856 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
3858 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3859 expr1
->ts
.u
.cl
->backend_decl
);
3862 type
= gfc_typenode_for_spec (&expr1
->ts
);
3864 /* Allocate temporary for nested forall construct according to the
3865 information in nested_forall_info and inner_size. */
3866 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
3867 &inner_size_body
, block
, &ptemp1
);
3869 /* Generate codes to copy rhs to the temporary . */
3870 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
3873 /* Generate body and loops according to the information in
3874 nested_forall_info. */
3875 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3876 gfc_add_expr_to_block (block
, tmp
);
3879 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3883 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3885 /* Generate codes to copy the temporary to lhs. */
3886 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
3889 /* Generate body and loops according to the information in
3890 nested_forall_info. */
3891 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3892 gfc_add_expr_to_block (block
, tmp
);
3896 /* Free the temporary. */
3897 tmp
= gfc_call_free (ptemp1
);
3898 gfc_add_expr_to_block (block
, tmp
);
3903 /* Translate pointer assignment inside FORALL which need temporary. */
3906 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3907 forall_info
* nested_forall_info
,
3908 stmtblock_t
* block
)
3915 gfc_array_info
*info
;
3922 tree tmp
, tmp1
, ptemp1
;
3924 count
= gfc_create_var (gfc_array_index_type
, "count");
3925 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3927 inner_size
= gfc_index_one_node
;
3928 lss
= gfc_walk_expr (expr1
);
3929 rss
= gfc_walk_expr (expr2
);
3930 if (lss
== gfc_ss_terminator
)
3932 type
= gfc_typenode_for_spec (&expr1
->ts
);
3933 type
= build_pointer_type (type
);
3935 /* Allocate temporary for nested forall construct according to the
3936 information in nested_forall_info and inner_size. */
3937 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
3938 inner_size
, NULL
, block
, &ptemp1
);
3939 gfc_start_block (&body
);
3940 gfc_init_se (&lse
, NULL
);
3941 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3942 gfc_init_se (&rse
, NULL
);
3943 rse
.want_pointer
= 1;
3944 gfc_conv_expr (&rse
, expr2
);
3945 gfc_add_block_to_block (&body
, &rse
.pre
);
3946 gfc_add_modify (&body
, lse
.expr
,
3947 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3948 gfc_add_block_to_block (&body
, &rse
.post
);
3950 /* Increment count. */
3951 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3952 count
, gfc_index_one_node
);
3953 gfc_add_modify (&body
, count
, tmp
);
3955 tmp
= gfc_finish_block (&body
);
3957 /* Generate body and loops according to the information in
3958 nested_forall_info. */
3959 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3960 gfc_add_expr_to_block (block
, tmp
);
3963 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3965 gfc_start_block (&body
);
3966 gfc_init_se (&lse
, NULL
);
3967 gfc_init_se (&rse
, NULL
);
3968 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3969 lse
.want_pointer
= 1;
3970 gfc_conv_expr (&lse
, expr1
);
3971 gfc_add_block_to_block (&body
, &lse
.pre
);
3972 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
3973 gfc_add_block_to_block (&body
, &lse
.post
);
3974 /* Increment count. */
3975 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3976 count
, gfc_index_one_node
);
3977 gfc_add_modify (&body
, count
, tmp
);
3978 tmp
= gfc_finish_block (&body
);
3980 /* Generate body and loops according to the information in
3981 nested_forall_info. */
3982 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3983 gfc_add_expr_to_block (block
, tmp
);
3987 gfc_init_loopinfo (&loop
);
3989 /* Associate the SS with the loop. */
3990 gfc_add_ss_to_loop (&loop
, rss
);
3992 /* Setup the scalarizing loops and bounds. */
3993 gfc_conv_ss_startstride (&loop
);
3995 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3997 info
= &rss
->info
->data
.array
;
3998 desc
= info
->descriptor
;
4000 /* Make a new descriptor. */
4001 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4002 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4003 loop
.from
, loop
.to
, 1,
4004 GFC_ARRAY_UNKNOWN
, true);
4006 /* Allocate temporary for nested forall construct. */
4007 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4008 inner_size
, NULL
, block
, &ptemp1
);
4009 gfc_start_block (&body
);
4010 gfc_init_se (&lse
, NULL
);
4011 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4012 lse
.direct_byref
= 1;
4013 gfc_conv_expr_descriptor (&lse
, expr2
);
4015 gfc_add_block_to_block (&body
, &lse
.pre
);
4016 gfc_add_block_to_block (&body
, &lse
.post
);
4018 /* Increment count. */
4019 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4020 count
, gfc_index_one_node
);
4021 gfc_add_modify (&body
, count
, tmp
);
4023 tmp
= gfc_finish_block (&body
);
4025 /* Generate body and loops according to the information in
4026 nested_forall_info. */
4027 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4028 gfc_add_expr_to_block (block
, tmp
);
4031 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4033 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4034 gfc_init_se (&lse
, NULL
);
4035 gfc_conv_expr_descriptor (&lse
, expr1
);
4036 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4037 gfc_start_block (&body
);
4038 gfc_add_block_to_block (&body
, &lse
.pre
);
4039 gfc_add_block_to_block (&body
, &lse
.post
);
4041 /* Increment count. */
4042 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4043 count
, gfc_index_one_node
);
4044 gfc_add_modify (&body
, count
, tmp
);
4046 tmp
= gfc_finish_block (&body
);
4048 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4049 gfc_add_expr_to_block (block
, tmp
);
4051 /* Free the temporary. */
4054 tmp
= gfc_call_free (ptemp1
);
4055 gfc_add_expr_to_block (block
, tmp
);
4060 /* FORALL and WHERE statements are really nasty, especially when you nest
4061 them. All the rhs of a forall assignment must be evaluated before the
4062 actual assignments are performed. Presumably this also applies to all the
4063 assignments in an inner where statement. */
4065 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4066 linear array, relying on the fact that we process in the same order in all
4069 forall (i=start:end:stride; maskexpr)
4073 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4075 count = ((end + 1 - start) / stride)
4076 masktmp(:) = maskexpr(:)
4079 for (i = start; i <= end; i += stride)
4081 if (masktmp[maskindex++])
4085 for (i = start; i <= end; i += stride)
4087 if (masktmp[maskindex++])
4091 Note that this code only works when there are no dependencies.
4092 Forall loop with array assignments and data dependencies are a real pain,
4093 because the size of the temporary cannot always be determined before the
4094 loop is executed. This problem is compounded by the presence of nested
4099 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4116 tree cycle_label
= NULL_TREE
;
4120 gfc_forall_iterator
*fa
;
4123 gfc_saved_var
*saved_vars
;
4124 iter_info
*this_forall
;
4128 /* Do nothing if the mask is false. */
4130 && code
->expr1
->expr_type
== EXPR_CONSTANT
4131 && !code
->expr1
->value
.logical
)
4132 return build_empty_stmt (input_location
);
4135 /* Count the FORALL index number. */
4136 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4140 /* Allocate the space for var, start, end, step, varexpr. */
4141 var
= XCNEWVEC (tree
, nvar
);
4142 start
= XCNEWVEC (tree
, nvar
);
4143 end
= XCNEWVEC (tree
, nvar
);
4144 step
= XCNEWVEC (tree
, nvar
);
4145 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4146 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4148 /* Allocate the space for info. */
4149 info
= XCNEW (forall_info
);
4151 gfc_start_block (&pre
);
4152 gfc_init_block (&post
);
4153 gfc_init_block (&block
);
4156 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4158 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4160 /* Allocate space for this_forall. */
4161 this_forall
= XCNEW (iter_info
);
4163 /* Create a temporary variable for the FORALL index. */
4164 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4165 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4166 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4168 /* Record it in this_forall. */
4169 this_forall
->var
= var
[n
];
4171 /* Replace the index symbol's backend_decl with the temporary decl. */
4172 sym
->backend_decl
= var
[n
];
4174 /* Work out the start, end and stride for the loop. */
4175 gfc_init_se (&se
, NULL
);
4176 gfc_conv_expr_val (&se
, fa
->start
);
4177 /* Record it in this_forall. */
4178 this_forall
->start
= se
.expr
;
4179 gfc_add_block_to_block (&block
, &se
.pre
);
4182 gfc_init_se (&se
, NULL
);
4183 gfc_conv_expr_val (&se
, fa
->end
);
4184 /* Record it in this_forall. */
4185 this_forall
->end
= se
.expr
;
4186 gfc_make_safe_expr (&se
);
4187 gfc_add_block_to_block (&block
, &se
.pre
);
4190 gfc_init_se (&se
, NULL
);
4191 gfc_conv_expr_val (&se
, fa
->stride
);
4192 /* Record it in this_forall. */
4193 this_forall
->step
= se
.expr
;
4194 gfc_make_safe_expr (&se
);
4195 gfc_add_block_to_block (&block
, &se
.pre
);
4198 /* Set the NEXT field of this_forall to NULL. */
4199 this_forall
->next
= NULL
;
4200 /* Link this_forall to the info construct. */
4201 if (info
->this_loop
)
4203 iter_info
*iter_tmp
= info
->this_loop
;
4204 while (iter_tmp
->next
!= NULL
)
4205 iter_tmp
= iter_tmp
->next
;
4206 iter_tmp
->next
= this_forall
;
4209 info
->this_loop
= this_forall
;
4215 /* Calculate the size needed for the current forall level. */
4216 size
= gfc_index_one_node
;
4217 for (n
= 0; n
< nvar
; n
++)
4219 /* size = (end + step - start) / step. */
4220 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4222 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4224 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4226 tmp
= convert (gfc_array_index_type
, tmp
);
4228 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4232 /* Record the nvar and size of current forall level. */
4238 /* If the mask is .true., consider the FORALL unconditional. */
4239 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4240 && code
->expr1
->value
.logical
)
4248 /* First we need to allocate the mask. */
4251 /* As the mask array can be very big, prefer compact boolean types. */
4252 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4253 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4254 size
, NULL
, &block
, &pmask
);
4255 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4257 /* Record them in the info structure. */
4258 info
->maskindex
= maskindex
;
4263 /* No mask was specified. */
4264 maskindex
= NULL_TREE
;
4265 mask
= pmask
= NULL_TREE
;
4268 /* Link the current forall level to nested_forall_info. */
4269 info
->prev_nest
= nested_forall_info
;
4270 nested_forall_info
= info
;
4272 /* Copy the mask into a temporary variable if required.
4273 For now we assume a mask temporary is needed. */
4276 /* As the mask array can be very big, prefer compact boolean types. */
4277 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4279 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4281 /* Start of mask assignment loop body. */
4282 gfc_start_block (&body
);
4284 /* Evaluate the mask expression. */
4285 gfc_init_se (&se
, NULL
);
4286 gfc_conv_expr_val (&se
, code
->expr1
);
4287 gfc_add_block_to_block (&body
, &se
.pre
);
4289 /* Store the mask. */
4290 se
.expr
= convert (mask_type
, se
.expr
);
4292 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4293 gfc_add_modify (&body
, tmp
, se
.expr
);
4295 /* Advance to the next mask element. */
4296 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4297 maskindex
, gfc_index_one_node
);
4298 gfc_add_modify (&body
, maskindex
, tmp
);
4300 /* Generate the loops. */
4301 tmp
= gfc_finish_block (&body
);
4302 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4303 gfc_add_expr_to_block (&block
, tmp
);
4306 if (code
->op
== EXEC_DO_CONCURRENT
)
4308 gfc_init_block (&body
);
4309 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4310 code
->cycle_label
= cycle_label
;
4311 tmp
= gfc_trans_code (code
->block
->next
);
4312 gfc_add_expr_to_block (&body
, tmp
);
4314 if (TREE_USED (cycle_label
))
4316 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4317 gfc_add_expr_to_block (&body
, tmp
);
4320 tmp
= gfc_finish_block (&body
);
4321 nested_forall_info
->do_concurrent
= true;
4322 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4323 gfc_add_expr_to_block (&block
, tmp
);
4327 c
= code
->block
->next
;
4329 /* TODO: loop merging in FORALL statements. */
4330 /* Now that we've got a copy of the mask, generate the assignment loops. */
4336 /* A scalar or array assignment. DO the simple check for
4337 lhs to rhs dependencies. These make a temporary for the
4338 rhs and form a second forall block to copy to variable. */
4339 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4341 /* Temporaries due to array assignment data dependencies introduce
4342 no end of problems. */
4344 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4345 nested_forall_info
, &block
);
4348 /* Use the normal assignment copying routines. */
4349 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4351 /* Generate body and loops. */
4352 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4354 gfc_add_expr_to_block (&block
, tmp
);
4357 /* Cleanup any temporary symtrees that have been made to deal
4358 with dependencies. */
4360 cleanup_forall_symtrees (c
);
4365 /* Translate WHERE or WHERE construct nested in FORALL. */
4366 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4369 /* Pointer assignment inside FORALL. */
4370 case EXEC_POINTER_ASSIGN
:
4371 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4373 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4374 nested_forall_info
, &block
);
4377 /* Use the normal assignment copying routines. */
4378 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4380 /* Generate body and loops. */
4381 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4383 gfc_add_expr_to_block (&block
, tmp
);
4388 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4389 gfc_add_expr_to_block (&block
, tmp
);
4392 /* Explicit subroutine calls are prevented by the frontend but interface
4393 assignments can legitimately produce them. */
4394 case EXEC_ASSIGN_CALL
:
4395 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4396 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4397 gfc_add_expr_to_block (&block
, tmp
);
4408 /* Restore the original index variables. */
4409 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4410 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4412 /* Free the space for var, start, end, step, varexpr. */
4420 for (this_forall
= info
->this_loop
; this_forall
;)
4422 iter_info
*next
= this_forall
->next
;
4427 /* Free the space for this forall_info. */
4432 /* Free the temporary for the mask. */
4433 tmp
= gfc_call_free (pmask
);
4434 gfc_add_expr_to_block (&block
, tmp
);
4437 pushdecl (maskindex
);
4439 gfc_add_block_to_block (&pre
, &block
);
4440 gfc_add_block_to_block (&pre
, &post
);
4442 return gfc_finish_block (&pre
);
4446 /* Translate the FORALL statement or construct. */
4448 tree
gfc_trans_forall (gfc_code
* code
)
4450 return gfc_trans_forall_1 (code
, NULL
);
4454 /* Translate the DO CONCURRENT construct. */
4456 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4458 return gfc_trans_forall_1 (code
, NULL
);
4462 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4463 If the WHERE construct is nested in FORALL, compute the overall temporary
4464 needed by the WHERE mask expression multiplied by the iterator number of
4466 ME is the WHERE mask expression.
4467 MASK is the current execution mask upon input, whose sense may or may
4468 not be inverted as specified by the INVERT argument.
4469 CMASK is the updated execution mask on output, or NULL if not required.
4470 PMASK is the pending execution mask on output, or NULL if not required.
4471 BLOCK is the block in which to place the condition evaluation loops. */
4474 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4475 tree mask
, bool invert
, tree cmask
, tree pmask
,
4476 tree mask_type
, stmtblock_t
* block
)
4481 stmtblock_t body
, body1
;
4482 tree count
, cond
, mtmp
;
4485 gfc_init_loopinfo (&loop
);
4487 lss
= gfc_walk_expr (me
);
4488 rss
= gfc_walk_expr (me
);
4490 /* Variable to index the temporary. */
4491 count
= gfc_create_var (gfc_array_index_type
, "count");
4492 /* Initialize count. */
4493 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4495 gfc_start_block (&body
);
4497 gfc_init_se (&rse
, NULL
);
4498 gfc_init_se (&lse
, NULL
);
4500 if (lss
== gfc_ss_terminator
)
4502 gfc_init_block (&body1
);
4506 /* Initialize the loop. */
4507 gfc_init_loopinfo (&loop
);
4509 /* We may need LSS to determine the shape of the expression. */
4510 gfc_add_ss_to_loop (&loop
, lss
);
4511 gfc_add_ss_to_loop (&loop
, rss
);
4513 gfc_conv_ss_startstride (&loop
);
4514 gfc_conv_loop_setup (&loop
, &me
->where
);
4516 gfc_mark_ss_chain_used (rss
, 1);
4517 /* Start the loop body. */
4518 gfc_start_scalarized_body (&loop
, &body1
);
4520 /* Translate the expression. */
4521 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4523 gfc_conv_expr (&rse
, me
);
4526 /* Variable to evaluate mask condition. */
4527 cond
= gfc_create_var (mask_type
, "cond");
4528 if (mask
&& (cmask
|| pmask
))
4529 mtmp
= gfc_create_var (mask_type
, "mask");
4530 else mtmp
= NULL_TREE
;
4532 gfc_add_block_to_block (&body1
, &lse
.pre
);
4533 gfc_add_block_to_block (&body1
, &rse
.pre
);
4535 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4537 if (mask
&& (cmask
|| pmask
))
4539 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4541 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4542 gfc_add_modify (&body1
, mtmp
, tmp
);
4547 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4550 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4552 gfc_add_modify (&body1
, tmp1
, tmp
);
4557 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4558 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4560 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4562 gfc_add_modify (&body1
, tmp1
, tmp
);
4565 gfc_add_block_to_block (&body1
, &lse
.post
);
4566 gfc_add_block_to_block (&body1
, &rse
.post
);
4568 if (lss
== gfc_ss_terminator
)
4570 gfc_add_block_to_block (&body
, &body1
);
4574 /* Increment count. */
4575 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4576 count
, gfc_index_one_node
);
4577 gfc_add_modify (&body1
, count
, tmp1
);
4579 /* Generate the copying loops. */
4580 gfc_trans_scalarizing_loops (&loop
, &body1
);
4582 gfc_add_block_to_block (&body
, &loop
.pre
);
4583 gfc_add_block_to_block (&body
, &loop
.post
);
4585 gfc_cleanup_loop (&loop
);
4586 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4587 as tree nodes in SS may not be valid in different scope. */
4590 tmp1
= gfc_finish_block (&body
);
4591 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4592 if (nested_forall_info
!= NULL
)
4593 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4595 gfc_add_expr_to_block (block
, tmp1
);
4599 /* Translate an assignment statement in a WHERE statement or construct
4600 statement. The MASK expression is used to control which elements
4601 of EXPR1 shall be assigned. The sense of MASK is specified by
4605 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4606 tree mask
, bool invert
,
4607 tree count1
, tree count2
,
4613 gfc_ss
*lss_section
;
4620 tree index
, maskexpr
;
4622 /* A defined assignment. */
4623 if (cnext
&& cnext
->resolved_sym
)
4624 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4627 /* TODO: handle this special case.
4628 Special case a single function returning an array. */
4629 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4631 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4637 /* Assignment of the form lhs = rhs. */
4638 gfc_start_block (&block
);
4640 gfc_init_se (&lse
, NULL
);
4641 gfc_init_se (&rse
, NULL
);
4644 lss
= gfc_walk_expr (expr1
);
4647 /* In each where-assign-stmt, the mask-expr and the variable being
4648 defined shall be arrays of the same shape. */
4649 gcc_assert (lss
!= gfc_ss_terminator
);
4651 /* The assignment needs scalarization. */
4654 /* Find a non-scalar SS from the lhs. */
4655 while (lss_section
!= gfc_ss_terminator
4656 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4657 lss_section
= lss_section
->next
;
4659 gcc_assert (lss_section
!= gfc_ss_terminator
);
4661 /* Initialize the scalarizer. */
4662 gfc_init_loopinfo (&loop
);
4665 rss
= gfc_walk_expr (expr2
);
4666 if (rss
== gfc_ss_terminator
)
4668 /* The rhs is scalar. Add a ss for the expression. */
4669 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4670 rss
->info
->where
= 1;
4673 /* Associate the SS with the loop. */
4674 gfc_add_ss_to_loop (&loop
, lss
);
4675 gfc_add_ss_to_loop (&loop
, rss
);
4677 /* Calculate the bounds of the scalarization. */
4678 gfc_conv_ss_startstride (&loop
);
4680 /* Resolve any data dependencies in the statement. */
4681 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4683 /* Setup the scalarizing loops. */
4684 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4686 /* Setup the gfc_se structures. */
4687 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4688 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4691 gfc_mark_ss_chain_used (rss
, 1);
4692 if (loop
.temp_ss
== NULL
)
4695 gfc_mark_ss_chain_used (lss
, 1);
4699 lse
.ss
= loop
.temp_ss
;
4700 gfc_mark_ss_chain_used (lss
, 3);
4701 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4704 /* Start the scalarized loop body. */
4705 gfc_start_scalarized_body (&loop
, &body
);
4707 /* Translate the expression. */
4708 gfc_conv_expr (&rse
, expr2
);
4709 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4710 gfc_conv_tmp_array_ref (&lse
);
4712 gfc_conv_expr (&lse
, expr1
);
4714 /* Form the mask expression according to the mask. */
4716 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4718 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4719 TREE_TYPE (maskexpr
), maskexpr
);
4721 /* Use the scalar assignment as is. */
4722 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4723 false, loop
.temp_ss
== NULL
);
4725 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4727 gfc_add_expr_to_block (&body
, tmp
);
4729 if (lss
== gfc_ss_terminator
)
4731 /* Increment count1. */
4732 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4733 count1
, gfc_index_one_node
);
4734 gfc_add_modify (&body
, count1
, tmp
);
4736 /* Use the scalar assignment as is. */
4737 gfc_add_block_to_block (&block
, &body
);
4741 gcc_assert (lse
.ss
== gfc_ss_terminator
4742 && rse
.ss
== gfc_ss_terminator
);
4744 if (loop
.temp_ss
!= NULL
)
4746 /* Increment count1 before finish the main body of a scalarized
4748 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4749 gfc_array_index_type
, count1
, gfc_index_one_node
);
4750 gfc_add_modify (&body
, count1
, tmp
);
4751 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4753 /* We need to copy the temporary to the actual lhs. */
4754 gfc_init_se (&lse
, NULL
);
4755 gfc_init_se (&rse
, NULL
);
4756 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4757 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4759 rse
.ss
= loop
.temp_ss
;
4762 gfc_conv_tmp_array_ref (&rse
);
4763 gfc_conv_expr (&lse
, expr1
);
4765 gcc_assert (lse
.ss
== gfc_ss_terminator
4766 && rse
.ss
== gfc_ss_terminator
);
4768 /* Form the mask expression according to the mask tree list. */
4770 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4772 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4773 TREE_TYPE (maskexpr
), maskexpr
);
4775 /* Use the scalar assignment as is. */
4776 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
4777 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
4778 build_empty_stmt (input_location
));
4779 gfc_add_expr_to_block (&body
, tmp
);
4781 /* Increment count2. */
4782 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4783 gfc_array_index_type
, count2
,
4784 gfc_index_one_node
);
4785 gfc_add_modify (&body
, count2
, tmp
);
4789 /* Increment count1. */
4790 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4791 gfc_array_index_type
, count1
,
4792 gfc_index_one_node
);
4793 gfc_add_modify (&body
, count1
, tmp
);
4796 /* Generate the copying loops. */
4797 gfc_trans_scalarizing_loops (&loop
, &body
);
4799 /* Wrap the whole thing up. */
4800 gfc_add_block_to_block (&block
, &loop
.pre
);
4801 gfc_add_block_to_block (&block
, &loop
.post
);
4802 gfc_cleanup_loop (&loop
);
4805 return gfc_finish_block (&block
);
4809 /* Translate the WHERE construct or statement.
4810 This function can be called iteratively to translate the nested WHERE
4811 construct or statement.
4812 MASK is the control mask. */
4815 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
4816 forall_info
* nested_forall_info
, stmtblock_t
* block
)
4818 stmtblock_t inner_size_body
;
4819 tree inner_size
, size
;
4828 tree count1
, count2
;
4832 tree pcmask
= NULL_TREE
;
4833 tree ppmask
= NULL_TREE
;
4834 tree cmask
= NULL_TREE
;
4835 tree pmask
= NULL_TREE
;
4836 gfc_actual_arglist
*arg
;
4838 /* the WHERE statement or the WHERE construct statement. */
4839 cblock
= code
->block
;
4841 /* As the mask array can be very big, prefer compact boolean types. */
4842 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4844 /* Determine which temporary masks are needed. */
4847 /* One clause: No ELSEWHEREs. */
4848 need_cmask
= (cblock
->next
!= 0);
4851 else if (cblock
->block
->block
)
4853 /* Three or more clauses: Conditional ELSEWHEREs. */
4857 else if (cblock
->next
)
4859 /* Two clauses, the first non-empty. */
4861 need_pmask
= (mask
!= NULL_TREE
4862 && cblock
->block
->next
!= 0);
4864 else if (!cblock
->block
->next
)
4866 /* Two clauses, both empty. */
4870 /* Two clauses, the first empty, the second non-empty. */
4873 need_cmask
= (cblock
->block
->expr1
!= 0);
4882 if (need_cmask
|| need_pmask
)
4884 /* Calculate the size of temporary needed by the mask-expr. */
4885 gfc_init_block (&inner_size_body
);
4886 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
4887 &inner_size_body
, &lss
, &rss
);
4889 gfc_free_ss_chain (lss
);
4890 gfc_free_ss_chain (rss
);
4892 /* Calculate the total size of temporary needed. */
4893 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4894 &inner_size_body
, block
);
4896 /* Check whether the size is negative. */
4897 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
4898 gfc_index_zero_node
);
4899 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
4900 cond
, gfc_index_zero_node
, size
);
4901 size
= gfc_evaluate_now (size
, block
);
4903 /* Allocate temporary for WHERE mask if needed. */
4905 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4908 /* Allocate temporary for !mask if needed. */
4910 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4916 /* Each time around this loop, the where clause is conditional
4917 on the value of mask and invert, which are updated at the
4918 bottom of the loop. */
4920 /* Has mask-expr. */
4923 /* Ensure that the WHERE mask will be evaluated exactly once.
4924 If there are no statements in this WHERE/ELSEWHERE clause,
4925 then we don't need to update the control mask (cmask).
4926 If this is the last clause of the WHERE construct, then
4927 we don't need to update the pending control mask (pmask). */
4929 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4931 cblock
->next
? cmask
: NULL_TREE
,
4932 cblock
->block
? pmask
: NULL_TREE
,
4935 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4937 (cblock
->next
|| cblock
->block
)
4938 ? cmask
: NULL_TREE
,
4939 NULL_TREE
, mask_type
, block
);
4943 /* It's a final elsewhere-stmt. No mask-expr is present. */
4947 /* The body of this where clause are controlled by cmask with
4948 sense specified by invert. */
4950 /* Get the assignment statement of a WHERE statement, or the first
4951 statement in where-body-construct of a WHERE construct. */
4952 cnext
= cblock
->next
;
4957 /* WHERE assignment statement. */
4958 case EXEC_ASSIGN_CALL
:
4960 arg
= cnext
->ext
.actual
;
4961 expr1
= expr2
= NULL
;
4962 for (; arg
; arg
= arg
->next
)
4974 expr1
= cnext
->expr1
;
4975 expr2
= cnext
->expr2
;
4977 if (nested_forall_info
!= NULL
)
4979 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
4980 if (need_temp
&& cnext
->op
!= EXEC_ASSIGN_CALL
)
4981 gfc_trans_assign_need_temp (expr1
, expr2
,
4983 nested_forall_info
, block
);
4986 /* Variables to control maskexpr. */
4987 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4988 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4989 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4990 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4992 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4997 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4999 gfc_add_expr_to_block (block
, tmp
);
5004 /* Variables to control maskexpr. */
5005 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5006 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5007 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5008 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5010 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5014 gfc_add_expr_to_block (block
, tmp
);
5019 /* WHERE or WHERE construct is part of a where-body-construct. */
5021 gfc_trans_where_2 (cnext
, cmask
, invert
,
5022 nested_forall_info
, block
);
5029 /* The next statement within the same where-body-construct. */
5030 cnext
= cnext
->next
;
5032 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5033 cblock
= cblock
->block
;
5034 if (mask
== NULL_TREE
)
5036 /* If we're the initial WHERE, we can simply invert the sense
5037 of the current mask to obtain the "mask" for the remaining
5044 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5050 /* If we allocated a pending mask array, deallocate it now. */
5053 tmp
= gfc_call_free (ppmask
);
5054 gfc_add_expr_to_block (block
, tmp
);
5057 /* If we allocated a current mask array, deallocate it now. */
5060 tmp
= gfc_call_free (pcmask
);
5061 gfc_add_expr_to_block (block
, tmp
);
5065 /* Translate a simple WHERE construct or statement without dependencies.
5066 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5067 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5068 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5071 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5073 stmtblock_t block
, body
;
5074 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5075 tree tmp
, cexpr
, tstmt
, estmt
;
5076 gfc_ss
*css
, *tdss
, *tsss
;
5077 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5081 bool maybe_workshare
= false;
5083 /* Allow the scalarizer to workshare simple where loops. */
5084 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5085 == OMPWS_WORKSHARE_FLAG
)
5087 maybe_workshare
= true;
5088 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5091 cond
= cblock
->expr1
;
5092 tdst
= cblock
->next
->expr1
;
5093 tsrc
= cblock
->next
->expr2
;
5094 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5095 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5097 gfc_start_block (&block
);
5098 gfc_init_loopinfo (&loop
);
5100 /* Handle the condition. */
5101 gfc_init_se (&cse
, NULL
);
5102 css
= gfc_walk_expr (cond
);
5103 gfc_add_ss_to_loop (&loop
, css
);
5105 /* Handle the then-clause. */
5106 gfc_init_se (&tdse
, NULL
);
5107 gfc_init_se (&tsse
, NULL
);
5108 tdss
= gfc_walk_expr (tdst
);
5109 tsss
= gfc_walk_expr (tsrc
);
5110 if (tsss
== gfc_ss_terminator
)
5112 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5113 tsss
->info
->where
= 1;
5115 gfc_add_ss_to_loop (&loop
, tdss
);
5116 gfc_add_ss_to_loop (&loop
, tsss
);
5120 /* Handle the else clause. */
5121 gfc_init_se (&edse
, NULL
);
5122 gfc_init_se (&esse
, NULL
);
5123 edss
= gfc_walk_expr (edst
);
5124 esss
= gfc_walk_expr (esrc
);
5125 if (esss
== gfc_ss_terminator
)
5127 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5128 esss
->info
->where
= 1;
5130 gfc_add_ss_to_loop (&loop
, edss
);
5131 gfc_add_ss_to_loop (&loop
, esss
);
5134 gfc_conv_ss_startstride (&loop
);
5135 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5137 gfc_mark_ss_chain_used (css
, 1);
5138 gfc_mark_ss_chain_used (tdss
, 1);
5139 gfc_mark_ss_chain_used (tsss
, 1);
5142 gfc_mark_ss_chain_used (edss
, 1);
5143 gfc_mark_ss_chain_used (esss
, 1);
5146 gfc_start_scalarized_body (&loop
, &body
);
5148 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5149 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5150 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5156 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5157 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5162 gfc_conv_expr (&cse
, cond
);
5163 gfc_add_block_to_block (&body
, &cse
.pre
);
5166 gfc_conv_expr (&tsse
, tsrc
);
5167 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5168 gfc_conv_tmp_array_ref (&tdse
);
5170 gfc_conv_expr (&tdse
, tdst
);
5174 gfc_conv_expr (&esse
, esrc
);
5175 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5176 gfc_conv_tmp_array_ref (&edse
);
5178 gfc_conv_expr (&edse
, edst
);
5181 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5182 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5184 : build_empty_stmt (input_location
);
5185 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5186 gfc_add_expr_to_block (&body
, tmp
);
5187 gfc_add_block_to_block (&body
, &cse
.post
);
5189 if (maybe_workshare
)
5190 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5191 gfc_trans_scalarizing_loops (&loop
, &body
);
5192 gfc_add_block_to_block (&block
, &loop
.pre
);
5193 gfc_add_block_to_block (&block
, &loop
.post
);
5194 gfc_cleanup_loop (&loop
);
5196 return gfc_finish_block (&block
);
5199 /* As the WHERE or WHERE construct statement can be nested, we call
5200 gfc_trans_where_2 to do the translation, and pass the initial
5201 NULL values for both the control mask and the pending control mask. */
5204 gfc_trans_where (gfc_code
* code
)
5210 cblock
= code
->block
;
5212 && cblock
->next
->op
== EXEC_ASSIGN
5213 && !cblock
->next
->next
)
5215 eblock
= cblock
->block
;
5218 /* A simple "WHERE (cond) x = y" statement or block is
5219 dependence free if cond is not dependent upon writing x,
5220 and the source y is unaffected by the destination x. */
5221 if (!gfc_check_dependency (cblock
->next
->expr1
,
5223 && !gfc_check_dependency (cblock
->next
->expr1
,
5224 cblock
->next
->expr2
, 0))
5225 return gfc_trans_where_3 (cblock
, NULL
);
5227 else if (!eblock
->expr1
5230 && eblock
->next
->op
== EXEC_ASSIGN
5231 && !eblock
->next
->next
)
5233 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5234 block is dependence free if cond is not dependent on writes
5235 to x1 and x2, y1 is not dependent on writes to x2, and y2
5236 is not dependent on writes to x1, and both y's are not
5237 dependent upon their own x's. In addition to this, the
5238 final two dependency checks below exclude all but the same
5239 array reference if the where and elswhere destinations
5240 are the same. In short, this is VERY conservative and this
5241 is needed because the two loops, required by the standard
5242 are coalesced in gfc_trans_where_3. */
5243 if (!gfc_check_dependency (cblock
->next
->expr1
,
5245 && !gfc_check_dependency (eblock
->next
->expr1
,
5247 && !gfc_check_dependency (cblock
->next
->expr1
,
5248 eblock
->next
->expr2
, 1)
5249 && !gfc_check_dependency (eblock
->next
->expr1
,
5250 cblock
->next
->expr2
, 1)
5251 && !gfc_check_dependency (cblock
->next
->expr1
,
5252 cblock
->next
->expr2
, 1)
5253 && !gfc_check_dependency (eblock
->next
->expr1
,
5254 eblock
->next
->expr2
, 1)
5255 && !gfc_check_dependency (cblock
->next
->expr1
,
5256 eblock
->next
->expr1
, 0)
5257 && !gfc_check_dependency (eblock
->next
->expr1
,
5258 cblock
->next
->expr1
, 0))
5259 return gfc_trans_where_3 (cblock
, eblock
);
5263 gfc_start_block (&block
);
5265 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5267 return gfc_finish_block (&block
);
5271 /* CYCLE a DO loop. The label decl has already been created by
5272 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5273 node at the head of the loop. We must mark the label as used. */
5276 gfc_trans_cycle (gfc_code
* code
)
5280 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5281 gcc_assert (cycle_label
);
5283 TREE_USED (cycle_label
) = 1;
5284 return build1_v (GOTO_EXPR
, cycle_label
);
5288 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5289 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5293 gfc_trans_exit (gfc_code
* code
)
5297 exit_label
= code
->ext
.which_construct
->exit_label
;
5298 gcc_assert (exit_label
);
5300 TREE_USED (exit_label
) = 1;
5301 return build1_v (GOTO_EXPR
, exit_label
);
5305 /* Translate the ALLOCATE statement. */
5308 gfc_trans_allocate (gfc_code
* code
)
5311 gfc_expr
*expr
, *e3rhs
= NULL
;
5321 tree al_vptr
, al_len
;
5322 /* If an expr3 is present, then store the tree for accessing its
5323 _vptr, and _len components in the variables, respectively. The
5324 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5325 the trees may be the NULL_TREE indicating that this is not
5326 available for expr3's type. */
5327 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5328 /* Classify what expr3 stores. */
5329 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5333 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
;
5334 gfc_symtree
*newsym
= NULL
;
5336 if (!code
->ext
.alloc
.list
)
5339 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5340 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5341 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5344 gfc_init_block (&block
);
5345 gfc_init_block (&post
);
5347 /* STAT= (and maybe ERRMSG=) is present. */
5351 tree gfc_int4_type_node
= gfc_get_int_type (4);
5352 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5354 /* ERRMSG= only makes sense with STAT=. */
5357 gfc_init_se (&se
, NULL
);
5358 se
.want_pointer
= 1;
5359 gfc_conv_expr_lhs (&se
, code
->expr2
);
5361 errlen
= se
.string_length
;
5365 errmsg
= null_pointer_node
;
5366 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5369 /* GOTO destinations. */
5370 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5371 label_finish
= gfc_build_label_decl (NULL_TREE
);
5372 TREE_USED (label_finish
) = 0;
5375 /* When an expr3 is present evaluate it only once. The standards prevent a
5376 dependency of expr3 on the objects in the allocate list. An expr3 can
5377 be pre-evaluated in all cases. One just has to make sure, to use the
5378 correct way, i.e., to get the descriptor or to get a reference
5382 bool vtab_needed
= false, temp_var_needed
= false,
5383 is_coarray
= gfc_is_coarray (code
->expr3
);
5385 /* Figure whether we need the vtab from expr3. */
5386 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5388 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5390 gfc_init_se (&se
, NULL
);
5391 /* When expr3 is a variable, i.e., a very simple expression,
5392 then convert it once here. */
5393 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5394 || code
->expr3
->expr_type
== EXPR_ARRAY
5395 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5397 if (!code
->expr3
->mold
5398 || code
->expr3
->ts
.type
== BT_CHARACTER
5400 || code
->ext
.alloc
.arr_spec_from_expr3
)
5402 /* Convert expr3 to a tree. For all "simple" expression just
5403 get the descriptor or the reference, respectively, depending
5404 on the rank of the expr. */
5405 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5406 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5409 gfc_conv_expr_reference (&se
, code
->expr3
);
5411 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5412 NOP_EXPR, which prevents gfortran from getting the vptr
5413 from the source=-expression. Remove the NOP_EXPR and go
5414 with the POINTER_PLUS_EXPR in this case. */
5415 if (code
->expr3
->ts
.type
== BT_CLASS
5416 && TREE_CODE (se
.expr
) == NOP_EXPR
5417 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5418 == POINTER_PLUS_EXPR
5420 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5422 /* Create a temp variable only for component refs to prevent
5423 having to go through the full deref-chain each time and to
5424 simplfy computation of array properties. */
5425 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5430 /* In all other cases evaluate the expr3. */
5431 symbol_attribute attr
;
5432 /* Get the descriptor for all arrays, that are not allocatable or
5433 pointer, because the latter are descriptors already.
5434 The exception are function calls returning a class object:
5435 The descriptor is stored in their results _data component, which
5436 is easier to access, when first a temporary variable for the
5437 result is created and the descriptor retrieved from there. */
5438 attr
= gfc_expr_attr (code
->expr3
);
5439 if (code
->expr3
->rank
!= 0
5440 && ((!attr
.allocatable
&& !attr
.pointer
)
5441 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5442 && code
->expr3
->ts
.type
!= BT_CLASS
)))
5443 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5445 gfc_conv_expr_reference (&se
, code
->expr3
);
5446 if (code
->expr3
->ts
.type
== BT_CLASS
)
5447 gfc_conv_class_to_class (&se
, code
->expr3
,
5451 temp_var_needed
= !VAR_P (se
.expr
);
5453 gfc_add_block_to_block (&block
, &se
.pre
);
5454 gfc_add_block_to_block (&post
, &se
.post
);
5456 /* Special case when string in expr3 is zero. */
5457 if (code
->expr3
->ts
.type
== BT_CHARACTER
5458 && integer_zerop (se
.string_length
))
5460 gfc_init_se (&se
, NULL
);
5461 temp_var_needed
= false;
5462 expr3_len
= integer_zero_node
;
5465 /* Prevent aliasing, i.e., se.expr may be already a
5466 variable declaration. */
5467 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5470 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5472 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5474 /* Get the array descriptor and prepare it to be assigned to the
5475 temporary variable var. For classes the array descriptor is
5476 in the _data component and the object goes into the
5477 GFC_DECL_SAVED_DESCRIPTOR. */
5478 if (code
->expr3
->ts
.type
== BT_CLASS
5479 && code
->expr3
->rank
!= 0)
5481 /* When an array_ref was in expr3, then the descriptor is the
5483 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5485 desc
= TREE_OPERAND (tmp
, 0);
5490 tmp
= gfc_class_data_get (tmp
);
5495 desc
= !is_coarray
? se
.expr
5496 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5497 /* We need a regular (non-UID) symbol here, therefore give a
5499 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5500 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5502 gfc_allocate_lang_decl (var
);
5503 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5505 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5507 /* Deallocate any allocatable components after all the allocations
5508 and assignments of expr3 have been completed. */
5509 if (code
->expr3
->ts
.type
== BT_DERIVED
5510 && code
->expr3
->rank
== 0
5511 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
)
5513 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
5515 gfc_add_expr_to_block (&post
, tmp
);
5519 if (se
.string_length
)
5520 /* Evaluate it assuming that it also is complicated like expr3. */
5521 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5526 expr3_len
= se
.string_length
;
5528 /* Store what the expr3 is to be used for. */
5529 if (e3_is
== E3_UNSET
)
5530 e3_is
= expr3
!= NULL_TREE
?
5531 (code
->ext
.alloc
.arr_spec_from_expr3
?
5533 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
5536 /* Figure how to get the _vtab entry. This also obtains the tree
5537 expression for accessing the _len component, because only
5538 unlimited polymorphic objects, which are a subcategory of class
5539 types, have a _len component. */
5540 if (code
->expr3
->ts
.type
== BT_CLASS
)
5543 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
5544 build_fold_indirect_ref (expr3
): expr3
;
5545 /* Polymorphic SOURCE: VPTR must be determined at run time.
5546 expr3 may be a temporary array declaration, therefore check for
5547 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5548 if (tmp
!= NULL_TREE
5549 && (e3_is
== E3_DESC
5550 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
5551 && (VAR_P (tmp
) || !code
->expr3
->ref
))
5552 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
5553 tmp
= gfc_class_vptr_get (expr3
);
5556 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5557 gfc_add_vptr_component (rhs
);
5558 gfc_init_se (&se
, NULL
);
5559 se
.want_pointer
= 1;
5560 gfc_conv_expr (&se
, rhs
);
5562 gfc_free_expr (rhs
);
5564 /* Set the element size. */
5565 expr3_esize
= gfc_vptr_size_get (tmp
);
5568 /* Initialize the ref to the _len component. */
5569 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5571 /* Same like for retrieving the _vptr. */
5572 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5573 expr3_len
= gfc_class_len_get (expr3
);
5576 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5577 gfc_add_len_component (rhs
);
5578 gfc_init_se (&se
, NULL
);
5579 gfc_conv_expr (&se
, rhs
);
5580 expr3_len
= se
.expr
;
5581 gfc_free_expr (rhs
);
5587 /* When the object to allocate is polymorphic type, then it
5588 needs its vtab set correctly, so deduce the required _vtab
5589 and _len from the source expression. */
5592 /* VPTR is fixed at compile time. */
5595 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5597 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5598 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5601 /* _len component needs to be set, when ts is a character
5603 if (expr3_len
== NULL_TREE
5604 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5606 if (code
->expr3
->ts
.u
.cl
5607 && code
->expr3
->ts
.u
.cl
->length
)
5609 gfc_init_se (&se
, NULL
);
5610 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5611 gfc_add_block_to_block (&block
, &se
.pre
);
5612 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5614 gcc_assert (expr3_len
);
5616 /* For character arrays only the kind's size is needed, because
5617 the array mem_size is _len * (elem_size = kind_size).
5618 For all other get the element size in the normal way. */
5619 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5620 expr3_esize
= TYPE_SIZE_UNIT (
5621 gfc_get_char_type (code
->expr3
->ts
.kind
));
5623 expr3_esize
= TYPE_SIZE_UNIT (
5624 gfc_typenode_for_spec (&code
->expr3
->ts
));
5626 /* The routine gfc_trans_assignment () already implements all
5627 techniques needed. Unfortunately we may have a temporary
5628 variable for the source= expression here. When that is the
5629 case convert this variable into a temporary gfc_expr of type
5630 EXPR_VARIABLE and used it as rhs for the assignment. The
5631 advantage is, that we get scalarizer support for free,
5632 don't have to take care about scalar to array treatment and
5633 will benefit of every enhancements gfc_trans_assignment ()
5635 No need to check whether e3_is is E3_UNSET, because that is
5636 done by expr3 != NULL_TREE.
5637 Exclude variables since the following block does not handle
5638 array sections. In any case, there is no harm in sending
5639 variables to gfc_trans_assignment because there is no
5640 evaluation of variables. */
5641 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
5642 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
5643 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5645 /* Build a temporary symtree and symbol. Do not add it to
5646 the current namespace to prevent accidently modifying
5647 a colliding symbol's as. */
5648 newsym
= XCNEW (gfc_symtree
);
5649 /* The name of the symtree should be unique, because
5650 gfc_create_var () took care about generating the
5652 newsym
->name
= gfc_get_string (IDENTIFIER_POINTER (
5653 DECL_NAME (expr3
)));
5654 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5655 /* The backend_decl is known. It is expr3, which is inserted
5657 newsym
->n
.sym
->backend_decl
= expr3
;
5658 e3rhs
= gfc_get_expr ();
5659 e3rhs
->ts
= code
->expr3
->ts
;
5660 e3rhs
->rank
= code
->expr3
->rank
;
5661 e3rhs
->symtree
= newsym
;
5662 /* Mark the symbol referenced or gfc_trans_assignment will
5664 newsym
->n
.sym
->attr
.referenced
= 1;
5665 e3rhs
->expr_type
= EXPR_VARIABLE
;
5666 e3rhs
->where
= code
->expr3
->where
;
5667 /* Set the symbols type, upto it was BT_UNKNOWN. */
5668 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5669 /* Check whether the expr3 is array valued. */
5672 gfc_array_spec
*arr
;
5673 arr
= gfc_get_array_spec ();
5674 arr
->rank
= e3rhs
->rank
;
5675 arr
->type
= AS_DEFERRED
;
5676 /* Set the dimension and pointer attribute for arrays
5677 to be on the safe side. */
5678 newsym
->n
.sym
->attr
.dimension
= 1;
5679 newsym
->n
.sym
->attr
.pointer
= 1;
5680 newsym
->n
.sym
->as
= arr
;
5681 gfc_add_full_array_ref (e3rhs
, arr
);
5683 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
5684 newsym
->n
.sym
->attr
.pointer
= 1;
5685 /* The string length is known to. Set it for char arrays. */
5686 if (e3rhs
->ts
.type
== BT_CHARACTER
)
5687 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
5688 gfc_commit_symbol (newsym
->n
.sym
);
5691 e3rhs
= gfc_copy_expr (code
->expr3
);
5693 gcc_assert (expr3_esize
);
5694 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5695 if (e3_is
== E3_MOLD
)
5696 /* The expr3 is no longer valid after this point. */
5699 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5701 /* Compute the explicit typespec given only once for all objects
5703 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5704 expr3_esize
= TYPE_SIZE_UNIT (
5705 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5709 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
);
5710 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5711 gfc_init_se (&se_sz
, NULL
);
5712 gfc_conv_expr (&se_sz
, sz
);
5714 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5715 tmp
= TYPE_SIZE_UNIT (tmp
);
5716 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5717 gfc_add_block_to_block (&block
, &se_sz
.pre
);
5718 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5719 TREE_TYPE (se_sz
.expr
),
5721 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
5725 /* Loop over all objects to allocate. */
5726 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5728 expr
= gfc_copy_expr (al
->expr
);
5729 /* UNLIMITED_POLY () needs the _data component to be set, when
5730 expr is a unlimited polymorphic object. But the _data component
5731 has not been set yet, so check the derived type's attr for the
5732 unlimited polymorphic flag to be safe. */
5733 upoly_expr
= UNLIMITED_POLY (expr
)
5734 || (expr
->ts
.type
== BT_DERIVED
5735 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
5736 gfc_init_se (&se
, NULL
);
5738 /* For class types prepare the expressions to ref the _vptr
5739 and the _len component. The latter for unlimited polymorphic
5741 if (expr
->ts
.type
== BT_CLASS
)
5743 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
5744 gfc_add_data_component (expr
);
5745 /* Prep the vptr handle. */
5746 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
5747 gfc_add_vptr_component (expr_ref_vptr
);
5748 se
.want_pointer
= 1;
5749 gfc_conv_expr (&se
, expr_ref_vptr
);
5751 se
.want_pointer
= 0;
5752 gfc_free_expr (expr_ref_vptr
);
5753 /* Allocated unlimited polymorphic objects always have a _len
5757 expr_ref_len
= gfc_copy_expr (al
->expr
);
5758 gfc_add_len_component (expr_ref_len
);
5759 gfc_conv_expr (&se
, expr_ref_len
);
5761 gfc_free_expr (expr_ref_len
);
5764 /* In a loop ensure that all loop variable dependent variables
5765 are initialized at the same spot in all execution paths. */
5769 al_vptr
= al_len
= NULL_TREE
;
5771 se
.want_pointer
= 1;
5772 se
.descriptor_only
= 1;
5774 gfc_conv_expr (&se
, expr
);
5775 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5776 /* se.string_length now stores the .string_length variable of expr
5777 needed to allocate character(len=:) arrays. */
5778 al_len
= se
.string_length
;
5780 al_len_needs_set
= al_len
!= NULL_TREE
;
5781 /* When allocating an array one can not use much of the
5782 pre-evaluated expr3 expressions, because for most of them the
5783 scalarizer is needed which is not available in the pre-evaluation
5784 step. Therefore gfc_array_allocate () is responsible (and able)
5785 to handle the complete array allocation. Only the element size
5786 needs to be provided, which is done most of the time by the
5787 pre-evaluation step. */
5789 if (expr3_len
&& code
->expr3
->ts
.type
== BT_CHARACTER
)
5790 /* When al is an array, then the element size for each element
5791 in the array is needed, which is the product of the len and
5792 esize for char arrays. */
5793 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5794 TREE_TYPE (expr3_esize
), expr3_esize
,
5795 fold_convert (TREE_TYPE (expr3_esize
),
5799 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
5800 label_finish
, tmp
, &nelems
,
5801 e3rhs
? e3rhs
: code
->expr3
,
5802 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
5803 code
->expr3
!= NULL
&& e3_is
== E3_DESC
5804 && code
->expr3
->expr_type
== EXPR_ARRAY
))
5806 /* A scalar or derived type. First compute the size to
5809 expr3_len is set when expr3 is an unlimited polymorphic
5810 object or a deferred length string. */
5811 if (expr3_len
!= NULL_TREE
)
5813 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
5814 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5815 TREE_TYPE (expr3_esize
),
5817 if (code
->expr3
->ts
.type
!= BT_CLASS
)
5818 /* expr3 is a deferred length string, i.e., we are
5823 /* For unlimited polymorphic enties build
5824 (len > 0) ? element_size * len : element_size
5825 to compute the number of bytes to allocate.
5826 This allows the allocation of unlimited polymorphic
5827 objects from an expr3 that is also unlimited
5828 polymorphic and stores a _len dependent object,
5830 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
5831 boolean_type_node
, expr3_len
,
5833 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
5834 TREE_TYPE (expr3_esize
),
5835 memsz
, tmp
, expr3_esize
);
5838 else if (expr3_esize
!= NULL_TREE
)
5839 /* Any other object in expr3 just needs element size in
5841 memsz
= expr3_esize
;
5842 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5844 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
5846 /* Allocating deferred length char arrays need the length
5847 to allocate in the alloc_type_spec. But also unlimited
5848 polymorphic objects may be allocated as char arrays.
5849 Both are handled here. */
5850 gfc_init_se (&se_sz
, NULL
);
5851 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5852 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5853 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
5854 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
5855 expr3_len
= se_sz
.expr
;
5856 tmp_expr3_len_flag
= true;
5857 tmp
= TYPE_SIZE_UNIT (
5858 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
5859 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5861 fold_convert (TREE_TYPE (tmp
),
5865 else if (expr
->ts
.type
== BT_CHARACTER
)
5867 /* Compute the number of bytes needed to allocate a fixed
5868 length char array. */
5869 gcc_assert (se
.string_length
!= NULL_TREE
);
5870 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
5871 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5872 TREE_TYPE (tmp
), tmp
,
5873 fold_convert (TREE_TYPE (tmp
),
5876 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5877 /* Handle all types, where the alloc_type_spec is set. */
5878 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5880 /* Handle size computation of the type declared to alloc. */
5881 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
5883 if (gfc_caf_attr (expr
).codimension
5884 && flag_coarray
== GFC_FCOARRAY_LIB
)
5886 /* Scalar allocatable components in coarray'ed derived types make
5887 it here and are treated now. */
5888 tree caf_decl
, token
;
5891 gfc_init_se (&caf_se
, NULL
);
5893 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
5894 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
5896 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
5897 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
5898 gfc_build_addr_expr (NULL_TREE
, token
),
5899 NULL_TREE
, NULL_TREE
, NULL_TREE
,
5900 label_finish
, expr
, 1);
5902 /* Allocate - for non-pointers with re-alloc checking. */
5903 else if (gfc_expr_attr (expr
).allocatable
)
5904 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
5905 NULL_TREE
, stat
, errmsg
, errlen
,
5906 label_finish
, expr
, 0);
5908 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
5910 if (al
->expr
->ts
.type
== BT_DERIVED
5911 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5913 tmp
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5914 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, tmp
, 0);
5915 gfc_add_expr_to_block (&se
.pre
, tmp
);
5920 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
5921 && expr3_len
!= NULL_TREE
)
5923 /* Arrays need to have a _len set before the array
5924 descriptor is filled. */
5925 gfc_add_modify (&block
, al_len
,
5926 fold_convert (TREE_TYPE (al_len
), expr3_len
));
5927 /* Prevent setting the length twice. */
5928 al_len_needs_set
= false;
5930 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
5931 && code
->ext
.alloc
.ts
.u
.cl
->length
)
5933 /* Cover the cases where a string length is explicitly
5934 specified by a type spec for deferred length character
5935 arrays or unlimited polymorphic objects without a
5936 source= or mold= expression. */
5937 gfc_init_se (&se_sz
, NULL
);
5938 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5939 gfc_add_block_to_block (&block
, &se_sz
.pre
);
5940 gfc_add_modify (&block
, al_len
,
5941 fold_convert (TREE_TYPE (al_len
),
5943 al_len_needs_set
= false;
5947 gfc_add_block_to_block (&block
, &se
.pre
);
5949 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
5952 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
5953 parm
= fold_build2_loc (input_location
, NE_EXPR
,
5954 boolean_type_node
, stat
,
5955 build_int_cst (TREE_TYPE (stat
), 0));
5956 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5957 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
5958 tmp
, build_empty_stmt (input_location
));
5959 gfc_add_expr_to_block (&block
, tmp
);
5963 if (al_vptr
!= NULL_TREE
)
5965 if (expr3_vptr
!= NULL_TREE
)
5966 /* The vtab is already known, so just assign it. */
5967 gfc_add_modify (&block
, al_vptr
,
5968 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
5971 /* VPTR is fixed at compile time. */
5976 /* Although expr3 is pre-evaluated above, it may happen,
5977 that for arrays or in mold= cases the pre-evaluation
5978 was not successful. In these rare cases take the vtab
5979 from the typespec of expr3 here. */
5980 ts
= &code
->expr3
->ts
;
5981 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
5982 /* The alloc_type_spec gives the type to allocate or the
5983 al is unlimited polymorphic, which enforces the use of
5984 an alloc_type_spec that is not necessarily a BT_DERIVED. */
5985 ts
= &code
->ext
.alloc
.ts
;
5987 /* Prepare for setting the vtab as declared. */
5990 vtab
= gfc_find_vtab (ts
);
5992 tmp
= gfc_build_addr_expr (NULL_TREE
,
5993 gfc_get_symbol_decl (vtab
));
5994 gfc_add_modify (&block
, al_vptr
,
5995 fold_convert (TREE_TYPE (al_vptr
), tmp
));
5999 /* Add assignment for string length. */
6000 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6002 if (expr3_len
!= NULL_TREE
)
6004 gfc_add_modify (&block
, al_len
,
6005 fold_convert (TREE_TYPE (al_len
),
6007 /* When tmp_expr3_len_flag is set, then expr3_len is
6008 abused to carry the length information from the
6009 alloc_type. Clear it to prevent setting incorrect len
6010 information in future loop iterations. */
6011 if (tmp_expr3_len_flag
)
6012 /* No need to reset tmp_expr3_len_flag, because the
6013 presence of an expr3 can not change within in the
6015 expr3_len
= NULL_TREE
;
6017 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6018 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6020 /* Cover the cases where a string length is explicitly
6021 specified by a type spec for deferred length character
6022 arrays or unlimited polymorphic objects without a
6023 source= or mold= expression. */
6024 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6026 gfc_init_se (&se_sz
, NULL
);
6027 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6028 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6029 gfc_add_modify (&block
, al_len
,
6030 fold_convert (TREE_TYPE (al_len
),
6034 gfc_add_modify (&block
, al_len
,
6035 fold_convert (TREE_TYPE (al_len
),
6039 /* No length information needed, because type to allocate
6040 has no length. Set _len to 0. */
6041 gfc_add_modify (&block
, al_len
,
6042 fold_convert (TREE_TYPE (al_len
),
6043 integer_zero_node
));
6045 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6047 /* Initialization via SOURCE block (or static default initializer).
6048 Classes need some special handling, so catch them first. */
6049 if (expr3
!= NULL_TREE
6050 && TREE_CODE (expr3
) != POINTER_PLUS_EXPR
6051 && code
->expr3
->ts
.type
== BT_CLASS
6052 && (expr
->ts
.type
== BT_CLASS
6053 || expr
->ts
.type
== BT_DERIVED
))
6055 /* copy_class_to_class can be used for class arrays, too.
6056 It just needs to be ensured, that the decl_saved_descriptor
6057 has a way to get to the vptr. */
6059 to
= VAR_P (se
.expr
) ? se
.expr
: TREE_OPERAND (se
.expr
, 0);
6060 tmp
= gfc_copy_class_to_class (expr3
, to
,
6061 nelems
, upoly_expr
);
6063 else if (al
->expr
->ts
.type
== BT_CLASS
)
6065 gfc_actual_arglist
*actual
, *last_arg
;
6068 gfc_ref
*ref
, *dataref
;
6069 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6071 /* Do a polymorphic deep copy. */
6072 actual
= gfc_get_actual_arglist ();
6073 actual
->expr
= gfc_copy_expr (rhs
);
6074 if (rhs
->ts
.type
== BT_CLASS
)
6075 gfc_add_data_component (actual
->expr
);
6076 last_arg
= actual
->next
= gfc_get_actual_arglist ();
6077 last_arg
->expr
= gfc_copy_expr (al
->expr
);
6078 last_arg
->expr
->ts
.type
= BT_CLASS
;
6079 gfc_add_data_component (last_arg
->expr
);
6082 /* Make sure we go up through the reference chain to
6083 the _data reference, where the arrayspec is found. */
6084 for (ref
= last_arg
->expr
->ref
; ref
; ref
= ref
->next
)
6085 if (ref
->type
== REF_COMPONENT
6086 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
6089 if (dataref
&& dataref
->u
.c
.component
->as
)
6091 gfc_array_spec
*as
= dataref
->u
.c
.component
->as
;
6092 gfc_free_ref_list (dataref
->next
);
6093 dataref
->next
= NULL
;
6094 gfc_add_full_array_ref (last_arg
->expr
, as
);
6095 gfc_resolve_expr (last_arg
->expr
);
6096 gcc_assert (last_arg
->expr
->ts
.type
== BT_CLASS
6097 || last_arg
->expr
->ts
.type
== BT_DERIVED
);
6098 last_arg
->expr
->ts
.type
= BT_CLASS
;
6100 if (rhs
->ts
.type
== BT_CLASS
)
6103 ppc
= gfc_find_and_cut_at_last_class_ref (rhs
);
6105 ppc
= gfc_copy_expr (rhs
);
6106 gfc_add_vptr_component (ppc
);
6109 ppc
= gfc_lval_expr_from_sym (gfc_find_vtab (&rhs
->ts
));
6110 gfc_add_component_ref (ppc
, "_copy");
6112 ppc_code
= gfc_get_code (EXEC_CALL
);
6113 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
6114 ppc_code
->loc
= al
->expr
->where
;
6115 /* Although '_copy' is set to be elemental in class.c, it is
6116 not staying that way. Find out why, sometime.... */
6117 ppc_code
->resolved_sym
->attr
.elemental
= 1;
6118 ppc_code
->ext
.actual
= actual
;
6119 ppc_code
->expr1
= ppc
;
6120 /* Since '_copy' is elemental, the scalarizer will take care
6121 of arrays in gfc_trans_call. */
6122 tmp
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
6123 /* We need to add the
6125 al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
6127 al_vptr->copy (expr3_data, al_data);
6128 block, because al is unlimited polymorphic or a deferred
6129 length char array, whose copy routine needs the array lengths
6130 as third and fourth arguments. */
6131 if (al_len
&& UNLIMITED_POLY (code
->expr3
))
6133 tree stdcopy
, extcopy
;
6135 last_arg
->next
= gfc_get_actual_arglist ();
6136 last_arg
= last_arg
->next
;
6137 last_arg
->expr
= gfc_find_and_cut_at_last_class_ref (
6139 gfc_add_len_component (last_arg
->expr
);
6140 /* Add expr3's length. */
6141 last_arg
->next
= gfc_get_actual_arglist ();
6142 last_arg
= last_arg
->next
;
6143 if (code
->expr3
->ts
.type
== BT_CLASS
)
6146 gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6147 gfc_add_len_component (last_arg
->expr
);
6149 else if (code
->expr3
->ts
.type
== BT_CHARACTER
)
6151 gfc_copy_expr (code
->expr3
->ts
.u
.cl
->length
);
6156 extcopy
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
6158 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
6159 boolean_type_node
, expr3_len
,
6161 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6162 void_type_node
, tmp
, extcopy
, stdcopy
);
6164 gfc_free_statements (ppc_code
);
6166 gfc_free_expr (rhs
);
6170 /* Switch off automatic reallocation since we have just
6171 done the ALLOCATE. */
6172 int realloc_lhs
= flag_realloc_lhs
;
6173 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6174 flag_realloc_lhs
= 0;
6175 tmp
= gfc_trans_assignment (init_expr
, e3rhs
, false, false);
6176 flag_realloc_lhs
= realloc_lhs
;
6177 /* Free the expression allocated for init_expr. */
6178 gfc_free_expr (init_expr
);
6180 gfc_add_expr_to_block (&block
, tmp
);
6182 else if (code
->expr3
&& code
->expr3
->mold
6183 && code
->expr3
->ts
.type
== BT_CLASS
)
6185 /* Since the _vptr has already been assigned to the allocate
6186 object, we can use gfc_copy_class_to_class in its
6187 initialization mode. */
6188 tmp
= TREE_OPERAND (se
.expr
, 0);
6189 tmp
= gfc_copy_class_to_class (NULL_TREE
, tmp
, nelems
,
6191 gfc_add_expr_to_block (&block
, tmp
);
6194 gfc_free_expr (expr
);
6201 gfc_free_symbol (newsym
->n
.sym
);
6204 gfc_free_expr (e3rhs
);
6209 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6210 gfc_add_expr_to_block (&block
, tmp
);
6213 /* ERRMSG - only useful if STAT is present. */
6214 if (code
->expr1
&& code
->expr2
)
6216 const char *msg
= "Attempt to allocate an allocated object";
6217 tree slen
, dlen
, errmsg_str
;
6218 stmtblock_t errmsg_block
;
6220 gfc_init_block (&errmsg_block
);
6222 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6223 gfc_add_modify (&errmsg_block
, errmsg_str
,
6224 gfc_build_addr_expr (pchar_type_node
,
6225 gfc_build_localized_cstring_const (msg
)));
6227 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6228 dlen
= gfc_get_expr_charlen (code
->expr2
);
6229 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6230 TREE_TYPE (slen
), dlen
, slen
);
6232 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6233 code
->expr2
->ts
.kind
,
6235 gfc_default_character_kind
);
6236 dlen
= gfc_finish_block (&errmsg_block
);
6238 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6239 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6241 tmp
= build3_v (COND_EXPR
, tmp
,
6242 dlen
, build_empty_stmt (input_location
));
6244 gfc_add_expr_to_block (&block
, tmp
);
6250 if (TREE_USED (label_finish
))
6252 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6253 gfc_add_expr_to_block (&block
, tmp
);
6256 gfc_init_se (&se
, NULL
);
6257 gfc_conv_expr_lhs (&se
, code
->expr1
);
6258 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6259 gfc_add_modify (&block
, se
.expr
, tmp
);
6262 gfc_add_block_to_block (&block
, &se
.post
);
6263 gfc_add_block_to_block (&block
, &post
);
6265 return gfc_finish_block (&block
);
6269 /* Translate a DEALLOCATE statement. */
6272 gfc_trans_deallocate (gfc_code
*code
)
6276 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6277 tree label_finish
, label_errmsg
;
6280 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6281 label_finish
= label_errmsg
= NULL_TREE
;
6283 gfc_start_block (&block
);
6285 /* Count the number of failed deallocations. If deallocate() was
6286 called with STAT= , then set STAT to the count. If deallocate
6287 was called with ERRMSG, then set ERRMG to a string. */
6290 tree gfc_int4_type_node
= gfc_get_int_type (4);
6292 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6293 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6295 /* GOTO destinations. */
6296 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6297 label_finish
= gfc_build_label_decl (NULL_TREE
);
6298 TREE_USED (label_finish
) = 0;
6301 /* Set ERRMSG - only needed if STAT is available. */
6302 if (code
->expr1
&& code
->expr2
)
6304 gfc_init_se (&se
, NULL
);
6305 se
.want_pointer
= 1;
6306 gfc_conv_expr_lhs (&se
, code
->expr2
);
6308 errlen
= se
.string_length
;
6311 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6313 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6314 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6316 if (expr
->ts
.type
== BT_CLASS
)
6317 gfc_add_data_component (expr
);
6319 gfc_init_se (&se
, NULL
);
6320 gfc_start_block (&se
.pre
);
6322 se
.want_pointer
= 1;
6323 se
.descriptor_only
= 1;
6324 gfc_conv_expr (&se
, expr
);
6326 if (expr
->rank
|| gfc_caf_attr (expr
).codimension
)
6330 if (gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.u
.derived
->attr
.alloc_comp
6331 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6333 gfc_ref
*last
= NULL
;
6335 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6336 if (ref
->type
== REF_COMPONENT
)
6339 /* Do not deallocate the components of a derived type
6340 ultimate pointer component. */
6341 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6342 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6344 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
.expr
,
6346 gfc_add_expr_to_block (&se
.pre
, tmp
);
6350 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6352 tmp
= gfc_array_deallocate (se
.expr
, pstat
, errmsg
, errlen
,
6353 label_finish
, expr
);
6354 gfc_add_expr_to_block (&se
.pre
, tmp
);
6356 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6357 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6358 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6361 /* class.c(finalize_component) generates these, when a
6362 finalizable entity has a non-allocatable derived type array
6363 component, which has allocatable components. Obtain the
6364 derived type of the array and deallocate the allocatable
6366 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6368 if (ref
->u
.c
.component
->attr
.dimension
6369 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6373 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6374 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6377 tmp
= gfc_deallocate_alloc_comp
6378 (ref
->u
.c
.component
->ts
.u
.derived
,
6379 se
.expr
, expr
->rank
);
6380 gfc_add_expr_to_block (&se
.pre
, tmp
);
6384 if (al
->expr
->ts
.type
== BT_CLASS
)
6386 gfc_reset_vptr (&se
.pre
, al
->expr
);
6387 if (UNLIMITED_POLY (al
->expr
)
6388 || (al
->expr
->ts
.type
== BT_DERIVED
6389 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6390 /* Clear _len, too. */
6391 gfc_reset_len (&se
.pre
, al
->expr
);
6396 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, false,
6397 al
->expr
, al
->expr
->ts
);
6398 gfc_add_expr_to_block (&se
.pre
, tmp
);
6400 /* Set to zero after deallocation. */
6401 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6403 build_int_cst (TREE_TYPE (se
.expr
), 0));
6404 gfc_add_expr_to_block (&se
.pre
, tmp
);
6406 if (al
->expr
->ts
.type
== BT_CLASS
)
6408 gfc_reset_vptr (&se
.pre
, al
->expr
);
6409 if (UNLIMITED_POLY (al
->expr
)
6410 || (al
->expr
->ts
.type
== BT_DERIVED
6411 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6412 /* Clear _len, too. */
6413 gfc_reset_len (&se
.pre
, al
->expr
);
6421 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6422 build_int_cst (TREE_TYPE (stat
), 0));
6423 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6424 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6425 build1_v (GOTO_EXPR
, label_errmsg
),
6426 build_empty_stmt (input_location
));
6427 gfc_add_expr_to_block (&se
.pre
, tmp
);
6430 tmp
= gfc_finish_block (&se
.pre
);
6431 gfc_add_expr_to_block (&block
, tmp
);
6432 gfc_free_expr (expr
);
6437 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6438 gfc_add_expr_to_block (&block
, tmp
);
6441 /* Set ERRMSG - only needed if STAT is available. */
6442 if (code
->expr1
&& code
->expr2
)
6444 const char *msg
= "Attempt to deallocate an unallocated object";
6445 stmtblock_t errmsg_block
;
6446 tree errmsg_str
, slen
, dlen
, cond
;
6448 gfc_init_block (&errmsg_block
);
6450 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6451 gfc_add_modify (&errmsg_block
, errmsg_str
,
6452 gfc_build_addr_expr (pchar_type_node
,
6453 gfc_build_localized_cstring_const (msg
)));
6454 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6455 dlen
= gfc_get_expr_charlen (code
->expr2
);
6457 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6458 slen
, errmsg_str
, gfc_default_character_kind
);
6459 tmp
= gfc_finish_block (&errmsg_block
);
6461 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6462 build_int_cst (TREE_TYPE (stat
), 0));
6463 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6464 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6465 build_empty_stmt (input_location
));
6467 gfc_add_expr_to_block (&block
, tmp
);
6470 if (code
->expr1
&& TREE_USED (label_finish
))
6472 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6473 gfc_add_expr_to_block (&block
, tmp
);
6479 gfc_init_se (&se
, NULL
);
6480 gfc_conv_expr_lhs (&se
, code
->expr1
);
6481 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6482 gfc_add_modify (&block
, se
.expr
, tmp
);
6485 return gfc_finish_block (&block
);
6488 #include "gt-fortran-trans-stmt.h"