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 (&token
, NULL
, caf_decl
, NULL_TREE
, code
->expr1
);
730 if (gfc_is_coindexed (code
->expr1
))
731 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
733 image_index
= integer_zero_node
;
735 /* For arrays, obtain the array index. */
736 if (gfc_expr_attr (code
->expr1
).dimension
)
738 tree desc
, tmp
, extent
, lbound
, ubound
;
739 gfc_array_ref
*ar
, ar2
;
742 /* TODO: Extend this, once DT components are supported. */
743 ar
= &code
->expr1
->ref
->u
.ar
;
745 memset (ar
, '\0', sizeof (*ar
));
749 gfc_init_se (&argse
, NULL
);
750 argse
.descriptor_only
= 1;
751 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
752 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
756 extent
= integer_one_node
;
757 for (i
= 0; i
< ar
->dimen
; i
++)
759 gfc_init_se (&argse
, NULL
);
760 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
761 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
762 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
763 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
764 integer_type_node
, argse
.expr
,
765 fold_convert(integer_type_node
, lbound
));
766 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
767 integer_type_node
, extent
, tmp
);
768 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
769 integer_type_node
, index
, tmp
);
770 if (i
< ar
->dimen
- 1)
772 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
773 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
774 tmp
= fold_convert (integer_type_node
, tmp
);
775 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
776 integer_type_node
, extent
, tmp
);
784 gfc_init_se (&argse
, NULL
);
785 argse
.want_pointer
= 1;
786 gfc_conv_expr (&argse
, code
->expr3
);
787 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
789 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
793 errmsg
= null_pointer_node
;
794 errmsg_len
= integer_zero_node
;
797 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
800 stat
= gfc_create_var (integer_type_node
, "stat");
803 if (lock_acquired
!= null_pointer_node
804 && TREE_TYPE (lock_acquired
) != integer_type_node
)
806 lock_acquired2
= lock_acquired
;
807 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
811 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
812 token
, index
, image_index
,
813 lock_acquired
!= null_pointer_node
814 ? gfc_build_addr_expr (NULL
, lock_acquired
)
816 stat
!= null_pointer_node
817 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
820 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
821 token
, index
, image_index
,
822 stat
!= null_pointer_node
823 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
825 gfc_add_expr_to_block (&se
.pre
, tmp
);
827 /* It guarantees memory consistency within the same segment */
828 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
829 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
830 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
831 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
832 ASM_VOLATILE_P (tmp
) = 1;
834 gfc_add_expr_to_block (&se
.pre
, tmp
);
836 if (stat2
!= NULL_TREE
)
837 gfc_add_modify (&se
.pre
, stat2
,
838 fold_convert (TREE_TYPE (stat2
), stat
));
840 if (lock_acquired2
!= NULL_TREE
)
841 gfc_add_modify (&se
.pre
, lock_acquired2
,
842 fold_convert (TREE_TYPE (lock_acquired2
),
845 return gfc_finish_block (&se
.pre
);
848 if (stat
!= NULL_TREE
)
849 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
851 if (lock_acquired
!= NULL_TREE
)
852 gfc_add_modify (&se
.pre
, lock_acquired
,
853 fold_convert (TREE_TYPE (lock_acquired
),
856 return gfc_finish_block (&se
.pre
);
860 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
863 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
864 tree until_count
= NULL_TREE
;
868 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
869 gfc_init_se (&argse
, NULL
);
870 gfc_conv_expr_val (&argse
, code
->expr2
);
873 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
874 stat
= null_pointer_node
;
878 gfc_init_se (&argse
, NULL
);
879 gfc_conv_expr_val (&argse
, code
->expr4
);
880 until_count
= fold_convert (integer_type_node
, argse
.expr
);
883 until_count
= integer_one_node
;
885 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
887 gfc_start_block (&se
.pre
);
888 gfc_init_se (&argse
, NULL
);
889 gfc_conv_expr_val (&argse
, code
->expr1
);
891 if (op
== EXEC_EVENT_POST
)
892 gfc_add_modify (&se
.pre
, argse
.expr
,
893 fold_build2_loc (input_location
, PLUS_EXPR
,
894 TREE_TYPE (argse
.expr
), argse
.expr
,
895 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
897 gfc_add_modify (&se
.pre
, argse
.expr
,
898 fold_build2_loc (input_location
, MINUS_EXPR
,
899 TREE_TYPE (argse
.expr
), argse
.expr
,
900 fold_convert (TREE_TYPE (argse
.expr
),
902 if (stat
!= NULL_TREE
)
903 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
905 return gfc_finish_block (&se
.pre
);
908 gfc_start_block (&se
.pre
);
909 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
910 tree index
= size_zero_node
;
911 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
913 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
914 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
915 != INTMOD_ISO_FORTRAN_ENV
916 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
917 != ISOFORTRAN_EVENT_TYPE
)
919 gfc_error ("Sorry, the event component of derived type at %L is not "
920 "yet supported", &code
->expr1
->where
);
924 gfc_get_caf_token_offset (&token
, NULL
, caf_decl
, NULL_TREE
, code
->expr1
);
926 if (gfc_is_coindexed (code
->expr1
))
927 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
929 image_index
= integer_zero_node
;
931 /* For arrays, obtain the array index. */
932 if (gfc_expr_attr (code
->expr1
).dimension
)
934 tree desc
, tmp
, extent
, lbound
, ubound
;
935 gfc_array_ref
*ar
, ar2
;
938 /* TODO: Extend this, once DT components are supported. */
939 ar
= &code
->expr1
->ref
->u
.ar
;
941 memset (ar
, '\0', sizeof (*ar
));
945 gfc_init_se (&argse
, NULL
);
946 argse
.descriptor_only
= 1;
947 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
948 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
952 extent
= integer_one_node
;
953 for (i
= 0; i
< ar
->dimen
; i
++)
955 gfc_init_se (&argse
, NULL
);
956 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
957 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
958 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
959 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
960 integer_type_node
, argse
.expr
,
961 fold_convert(integer_type_node
, lbound
));
962 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
963 integer_type_node
, extent
, tmp
);
964 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
965 integer_type_node
, index
, tmp
);
966 if (i
< ar
->dimen
- 1)
968 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
969 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
970 tmp
= fold_convert (integer_type_node
, tmp
);
971 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
972 integer_type_node
, extent
, tmp
);
980 gfc_init_se (&argse
, NULL
);
981 argse
.want_pointer
= 1;
982 gfc_conv_expr (&argse
, code
->expr3
);
983 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
985 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
989 errmsg
= null_pointer_node
;
990 errmsg_len
= integer_zero_node
;
993 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
996 stat
= gfc_create_var (integer_type_node
, "stat");
999 if (op
== EXEC_EVENT_POST
)
1000 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1001 token
, index
, image_index
,
1002 stat
!= null_pointer_node
1003 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1004 errmsg
, errmsg_len
);
1006 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1007 token
, index
, until_count
,
1008 stat
!= null_pointer_node
1009 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1010 errmsg
, errmsg_len
);
1011 gfc_add_expr_to_block (&se
.pre
, tmp
);
1013 /* It guarantees memory consistency within the same segment */
1014 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1015 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1016 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1017 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1018 ASM_VOLATILE_P (tmp
) = 1;
1019 gfc_add_expr_to_block (&se
.pre
, tmp
);
1021 if (stat2
!= NULL_TREE
)
1022 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1024 return gfc_finish_block (&se
.pre
);
1028 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1032 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1033 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1035 /* Short cut: For single images without bound checking or without STAT=,
1036 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1037 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1038 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1041 gfc_init_se (&se
, NULL
);
1042 gfc_start_block (&se
.pre
);
1044 if (code
->expr1
&& code
->expr1
->rank
== 0)
1046 gfc_init_se (&argse
, NULL
);
1047 gfc_conv_expr_val (&argse
, code
->expr1
);
1048 images
= argse
.expr
;
1053 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1054 gfc_init_se (&argse
, NULL
);
1055 gfc_conv_expr_val (&argse
, code
->expr2
);
1059 stat
= null_pointer_node
;
1061 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1063 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
1064 gfc_init_se (&argse
, NULL
);
1065 argse
.want_pointer
= 1;
1066 gfc_conv_expr (&argse
, code
->expr3
);
1067 gfc_conv_string_parameter (&argse
);
1068 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1069 errmsglen
= argse
.string_length
;
1071 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1073 errmsg
= null_pointer_node
;
1074 errmsglen
= build_int_cst (integer_type_node
, 0);
1077 /* Check SYNC IMAGES(imageset) for valid image index.
1078 FIXME: Add a check for image-set arrays. */
1079 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1080 && code
->expr1
->rank
== 0)
1083 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1084 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1085 images
, build_int_cst (TREE_TYPE (images
), 1));
1089 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1090 2, integer_zero_node
,
1091 build_int_cst (integer_type_node
, -1));
1092 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1094 cond2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1096 build_int_cst (TREE_TYPE (images
), 1));
1097 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1098 boolean_type_node
, cond
, cond2
);
1100 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1101 &code
->expr1
->where
, "Invalid image number "
1102 "%d in SYNC IMAGES",
1103 fold_convert (integer_type_node
, images
));
1106 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1107 image control statements SYNC IMAGES and SYNC ALL. */
1108 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1110 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1111 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1112 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1113 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1114 ASM_VOLATILE_P (tmp
) = 1;
1115 gfc_add_expr_to_block (&se
.pre
, tmp
);
1118 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1120 /* Set STAT to zero. */
1122 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1124 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1126 /* SYNC ALL => stat == null_pointer_node
1127 SYNC ALL(stat=s) => stat has an integer type
1129 If "stat" has the wrong integer type, use a temp variable of
1130 the right type and later cast the result back into "stat". */
1131 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1133 if (TREE_TYPE (stat
) == integer_type_node
)
1134 stat
= gfc_build_addr_expr (NULL
, stat
);
1136 if(type
== EXEC_SYNC_MEMORY
)
1137 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1138 3, stat
, errmsg
, errmsglen
);
1140 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1141 3, stat
, errmsg
, errmsglen
);
1143 gfc_add_expr_to_block (&se
.pre
, tmp
);
1147 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1149 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1150 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1152 gfc_add_expr_to_block (&se
.pre
, tmp
);
1154 gfc_add_modify (&se
.pre
, stat
,
1155 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1162 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1166 len
= build_int_cst (integer_type_node
, -1);
1167 images
= null_pointer_node
;
1169 else if (code
->expr1
->rank
== 0)
1171 len
= build_int_cst (integer_type_node
, 1);
1172 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1177 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1178 gfc_fatal_error ("Sorry, only support for integer kind %d "
1179 "implemented for image-set at %L",
1180 gfc_c_int_kind
, &code
->expr1
->where
);
1182 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1185 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1186 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1187 tmp
= gfc_get_element_type (tmp
);
1189 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1190 TREE_TYPE (len
), len
,
1191 fold_convert (TREE_TYPE (len
),
1192 TYPE_SIZE_UNIT (tmp
)));
1193 len
= fold_convert (integer_type_node
, len
);
1196 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1197 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1199 If "stat" has the wrong integer type, use a temp variable of
1200 the right type and later cast the result back into "stat". */
1201 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1203 if (TREE_TYPE (stat
) == integer_type_node
)
1204 stat
= gfc_build_addr_expr (NULL
, stat
);
1206 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1207 5, fold_convert (integer_type_node
, len
),
1208 images
, stat
, errmsg
, errmsglen
);
1209 gfc_add_expr_to_block (&se
.pre
, tmp
);
1213 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1215 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1216 5, fold_convert (integer_type_node
, len
),
1217 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1219 gfc_add_expr_to_block (&se
.pre
, tmp
);
1221 gfc_add_modify (&se
.pre
, stat
,
1222 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1226 return gfc_finish_block (&se
.pre
);
1230 /* Generate GENERIC for the IF construct. This function also deals with
1231 the simple IF statement, because the front end translates the IF
1232 statement into an IF construct.
1264 where COND_S is the simplified version of the predicate. PRE_COND_S
1265 are the pre side-effects produced by the translation of the
1267 We need to build the chain recursively otherwise we run into
1268 problems with folding incomplete statements. */
1271 gfc_trans_if_1 (gfc_code
* code
)
1274 tree stmt
, elsestmt
;
1278 /* Check for an unconditional ELSE clause. */
1280 return gfc_trans_code (code
->next
);
1282 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1283 gfc_init_se (&if_se
, NULL
);
1284 gfc_start_block (&if_se
.pre
);
1286 /* Calculate the IF condition expression. */
1287 if (code
->expr1
->where
.lb
)
1289 gfc_save_backend_locus (&saved_loc
);
1290 gfc_set_backend_locus (&code
->expr1
->where
);
1293 gfc_conv_expr_val (&if_se
, code
->expr1
);
1295 if (code
->expr1
->where
.lb
)
1296 gfc_restore_backend_locus (&saved_loc
);
1298 /* Translate the THEN clause. */
1299 stmt
= gfc_trans_code (code
->next
);
1301 /* Translate the ELSE clause. */
1303 elsestmt
= gfc_trans_if_1 (code
->block
);
1305 elsestmt
= build_empty_stmt (input_location
);
1307 /* Build the condition expression and add it to the condition block. */
1308 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1309 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1312 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1314 /* Finish off this statement. */
1315 return gfc_finish_block (&if_se
.pre
);
1319 gfc_trans_if (gfc_code
* code
)
1324 /* Create exit label so it is available for trans'ing the body code. */
1325 exit_label
= gfc_build_label_decl (NULL_TREE
);
1326 code
->exit_label
= exit_label
;
1328 /* Translate the actual code in code->block. */
1329 gfc_init_block (&body
);
1330 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1332 /* Add exit label. */
1333 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1335 return gfc_finish_block (&body
);
1339 /* Translate an arithmetic IF expression.
1341 IF (cond) label1, label2, label3 translates to
1353 An optimized version can be generated in case of equal labels.
1354 E.g., if label1 is equal to label2, we can translate it to
1363 gfc_trans_arithmetic_if (gfc_code
* code
)
1371 /* Start a new block. */
1372 gfc_init_se (&se
, NULL
);
1373 gfc_start_block (&se
.pre
);
1375 /* Pre-evaluate COND. */
1376 gfc_conv_expr_val (&se
, code
->expr1
);
1377 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1379 /* Build something to compare with. */
1380 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1382 if (code
->label1
->value
!= code
->label2
->value
)
1384 /* If (cond < 0) take branch1 else take branch2.
1385 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1386 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1387 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1389 if (code
->label1
->value
!= code
->label3
->value
)
1390 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1393 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1396 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1397 tmp
, branch1
, branch2
);
1400 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1402 if (code
->label1
->value
!= code
->label3
->value
1403 && code
->label2
->value
!= code
->label3
->value
)
1405 /* if (cond <= 0) take branch1 else take branch2. */
1406 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1407 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1409 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1410 tmp
, branch1
, branch2
);
1413 /* Append the COND_EXPR to the evaluation of COND, and return. */
1414 gfc_add_expr_to_block (&se
.pre
, branch1
);
1415 return gfc_finish_block (&se
.pre
);
1419 /* Translate a CRITICAL block. */
1421 gfc_trans_critical (gfc_code
*code
)
1424 tree tmp
, token
= NULL_TREE
;
1426 gfc_start_block (&block
);
1428 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1430 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1431 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1432 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1433 token
, integer_zero_node
, integer_one_node
,
1434 null_pointer_node
, null_pointer_node
,
1435 null_pointer_node
, integer_zero_node
);
1436 gfc_add_expr_to_block (&block
, tmp
);
1438 /* It guarantees memory consistency within the same segment */
1439 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1440 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1441 gfc_build_string_const (1, ""),
1442 NULL_TREE
, NULL_TREE
,
1443 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1445 ASM_VOLATILE_P (tmp
) = 1;
1447 gfc_add_expr_to_block (&block
, tmp
);
1450 tmp
= gfc_trans_code (code
->block
->next
);
1451 gfc_add_expr_to_block (&block
, tmp
);
1453 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1455 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1456 token
, integer_zero_node
, integer_one_node
,
1457 null_pointer_node
, null_pointer_node
,
1459 gfc_add_expr_to_block (&block
, tmp
);
1461 /* It guarantees memory consistency within the same segment */
1462 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1463 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1464 gfc_build_string_const (1, ""),
1465 NULL_TREE
, NULL_TREE
,
1466 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1468 ASM_VOLATILE_P (tmp
) = 1;
1470 gfc_add_expr_to_block (&block
, tmp
);
1473 return gfc_finish_block (&block
);
1477 /* Return true, when the class has a _len component. */
1480 class_has_len_component (gfc_symbol
*sym
)
1482 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1485 if (strcmp (comp
->name
, "_len") == 0)
1493 /* Do proper initialization for ASSOCIATE names. */
1496 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1507 bool need_len_assign
;
1509 gcc_assert (sym
->assoc
);
1510 e
= sym
->assoc
->target
;
1512 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1513 && (gfc_is_class_scalar_expr (e
)
1514 || gfc_is_class_array_ref (e
, NULL
));
1516 unlimited
= UNLIMITED_POLY (e
);
1518 /* Assignments to the string length need to be generated, when
1519 ( sym is a char array or
1520 sym has a _len component)
1521 and the associated expression is unlimited polymorphic, which is
1522 not (yet) correctly in 'unlimited', because for an already associated
1523 BT_DERIVED the u-poly flag is not set, i.e.,
1524 __tmp_CHARACTER_0_1 => w => arg
1525 ^ generated temp ^ from code, the w does not have the u-poly
1526 flag set, where UNLIMITED_POLY(e) expects it. */
1527 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1528 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1529 && (sym
->ts
.type
== BT_CHARACTER
1530 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1531 && class_has_len_component (sym
))));
1532 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1533 to array temporary) for arrays with either unknown shape or if associating
1535 if (sym
->attr
.dimension
&& !class_target
1536 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1540 bool cst_array_ctor
;
1542 desc
= sym
->backend_decl
;
1543 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1544 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1546 /* If association is to an expression, evaluate it and create temporary.
1547 Otherwise, get descriptor of target for pointer assignment. */
1548 gfc_init_se (&se
, NULL
);
1549 if (sym
->assoc
->variable
|| cst_array_ctor
)
1551 se
.direct_byref
= 1;
1556 gfc_conv_expr_descriptor (&se
, e
);
1558 /* If we didn't already do the pointer assignment, set associate-name
1559 descriptor to the one generated for the temporary. */
1560 if (!sym
->assoc
->variable
&& !cst_array_ctor
)
1564 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1566 /* The generated descriptor has lower bound zero (as array
1567 temporary), shift bounds so we get lower bounds of 1. */
1568 for (dim
= 0; dim
< e
->rank
; ++dim
)
1569 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1570 dim
, gfc_index_one_node
);
1573 /* If this is a subreference array pointer associate name use the
1574 associate variable element size for the value of 'span'. */
1575 if (sym
->attr
.subref_array_pointer
)
1577 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1578 tmp
= e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1579 ? gfc_class_data_get (e
->symtree
->n
.sym
->backend_decl
)
1580 : e
->symtree
->n
.sym
->backend_decl
;
1581 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1582 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1583 gfc_add_modify (&se
.pre
, GFC_DECL_SPAN(desc
), tmp
);
1586 /* Done, register stuff as init / cleanup code. */
1587 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1588 gfc_finish_block (&se
.post
));
1591 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1592 arrays to be assigned directly. */
1593 else if (class_target
&& sym
->attr
.dimension
1594 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1598 gfc_init_se (&se
, NULL
);
1599 se
.descriptor_only
= 1;
1600 /* In a select type the (temporary) associate variable shall point to
1601 a standard fortran array (lower bound == 1), but conv_expr ()
1602 just maps to the input array in the class object, whose lbound may
1603 be arbitrary. conv_expr_descriptor solves this by inserting a
1604 temporary array descriptor. */
1605 gfc_conv_expr_descriptor (&se
, e
);
1607 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1608 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1609 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1611 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1613 if (INDIRECT_REF_P (se
.expr
))
1614 tmp
= TREE_OPERAND (se
.expr
, 0);
1618 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1619 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1622 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1626 /* Recover the dtype, which has been overwritten by the
1627 assignment from an unlimited polymorphic object. */
1628 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1629 gfc_add_modify (&se
.pre
, tmp
,
1630 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1633 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1634 gfc_finish_block (&se
.post
));
1637 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1638 else if (gfc_is_associate_pointer (sym
))
1642 gcc_assert (!sym
->attr
.dimension
);
1644 gfc_init_se (&se
, NULL
);
1646 /* Class associate-names come this way because they are
1647 unconditionally associate pointers and the symbol is scalar. */
1648 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1651 /* For a class array we need a descriptor for the selector. */
1652 gfc_conv_expr_descriptor (&se
, e
);
1653 /* Needed to get/set the _len component below. */
1654 target_expr
= se
.expr
;
1656 /* Obtain a temporary class container for the result. */
1657 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1658 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1660 /* Set the offset. */
1661 desc
= gfc_class_data_get (se
.expr
);
1662 offset
= gfc_index_zero_node
;
1663 for (n
= 0; n
< e
->rank
; n
++)
1665 dim
= gfc_rank_cst
[n
];
1666 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1667 gfc_array_index_type
,
1668 gfc_conv_descriptor_stride_get (desc
, dim
),
1669 gfc_conv_descriptor_lbound_get (desc
, dim
));
1670 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1671 gfc_array_index_type
,
1674 if (need_len_assign
)
1677 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1678 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1679 /* Use the original class descriptor stored in the saved
1680 descriptor to get the target_expr. */
1682 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1684 /* Strip the _data component from the target_expr. */
1685 target_expr
= TREE_OPERAND (target_expr
, 0);
1686 /* Add a reference to the _len comp to the target expr. */
1687 tmp
= gfc_class_len_get (target_expr
);
1688 /* Get the component-ref for the temp structure's _len comp. */
1689 charlen
= gfc_class_len_get (se
.expr
);
1690 /* Add the assign to the beginning of the block... */
1691 gfc_add_modify (&se
.pre
, charlen
,
1692 fold_convert (TREE_TYPE (charlen
), tmp
));
1693 /* and the oposite way at the end of the block, to hand changes
1694 on the string length back. */
1695 gfc_add_modify (&se
.post
, tmp
,
1696 fold_convert (TREE_TYPE (tmp
), charlen
));
1697 /* Length assignment done, prevent adding it again below. */
1698 need_len_assign
= false;
1700 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1702 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1703 && CLASS_DATA (e
)->attr
.dimension
)
1705 /* This is bound to be a class array element. */
1706 gfc_conv_expr_reference (&se
, e
);
1707 /* Get the _vptr component of the class object. */
1708 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1709 /* Obtain a temporary class container for the result. */
1710 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1711 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1715 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1716 which has the string length included. For CHARACTERS it is still
1717 needed and will be done at the end of this routine. */
1718 gfc_conv_expr (&se
, e
);
1719 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1722 tmp
= TREE_TYPE (sym
->backend_decl
);
1723 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1724 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1726 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1727 gfc_finish_block (&se
.post
));
1730 /* Do a simple assignment. This is for scalar expressions, where we
1731 can simply use expression assignment. */
1736 lhs
= gfc_lval_expr_from_sym (sym
);
1737 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1738 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1741 /* Set the stringlength, when needed. */
1742 if (need_len_assign
)
1745 gfc_init_se (&se
, NULL
);
1746 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1748 /* What about deferred strings? */
1749 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1750 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1753 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1754 gfc_get_symbol_decl (sym
);
1755 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1756 : gfc_class_len_get (sym
->backend_decl
);
1757 /* Prevent adding a noop len= len. */
1760 gfc_add_modify (&se
.pre
, charlen
,
1761 fold_convert (TREE_TYPE (charlen
), tmp
));
1762 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1763 gfc_finish_block (&se
.post
));
1769 /* Translate a BLOCK construct. This is basically what we would do for a
1773 gfc_trans_block_construct (gfc_code
* code
)
1777 gfc_wrapped_block block
;
1780 gfc_association_list
*ass
;
1782 ns
= code
->ext
.block
.ns
;
1784 sym
= ns
->proc_name
;
1787 /* Process local variables. */
1788 gcc_assert (!sym
->tlink
);
1790 gfc_process_block_locals (ns
);
1792 /* Generate code including exit-label. */
1793 gfc_init_block (&body
);
1794 exit_label
= gfc_build_label_decl (NULL_TREE
);
1795 code
->exit_label
= exit_label
;
1797 finish_oacc_declare (ns
, sym
, true);
1799 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1800 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1802 /* Finish everything. */
1803 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1804 gfc_trans_deferred_vars (sym
, &block
);
1805 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1806 trans_associate_var (ass
->st
->n
.sym
, &block
);
1808 return gfc_finish_wrapped_block (&block
);
1812 /* Translate the simple DO construct. This is where the loop variable has
1813 integer type and step +-1. We can't use this in the general case
1814 because integer overflow and floating point errors could give incorrect
1816 We translate a do loop from:
1818 DO dovar = from, to, step
1824 [Evaluate loop bounds and step]
1826 if ((step > 0) ? (dovar <= to) : (dovar => to))
1832 cond = (dovar == to);
1834 if (cond) goto end_label;
1839 This helps the optimizers by avoiding the extra induction variable
1840 used in the general case. */
1843 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1844 tree from
, tree to
, tree step
, tree exit_cond
)
1850 tree saved_dovar
= NULL
;
1855 type
= TREE_TYPE (dovar
);
1857 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1859 /* Initialize the DO variable: dovar = from. */
1860 gfc_add_modify_loc (loc
, pblock
, dovar
,
1861 fold_convert (TREE_TYPE(dovar
), from
));
1863 /* Save value for do-tinkering checking. */
1864 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1866 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1867 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1870 /* Cycle and exit statements are implemented with gotos. */
1871 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1872 exit_label
= gfc_build_label_decl (NULL_TREE
);
1874 /* Put the labels where they can be found later. See gfc_trans_do(). */
1875 code
->cycle_label
= cycle_label
;
1876 code
->exit_label
= exit_label
;
1879 gfc_start_block (&body
);
1881 /* Main loop body. */
1882 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1883 gfc_add_expr_to_block (&body
, tmp
);
1885 /* Label for cycle statements (if needed). */
1886 if (TREE_USED (cycle_label
))
1888 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1889 gfc_add_expr_to_block (&body
, tmp
);
1892 /* Check whether someone has modified the loop variable. */
1893 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1895 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
1896 dovar
, saved_dovar
);
1897 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1898 "Loop variable has been modified");
1901 /* Exit the loop if there is an I/O result condition or error. */
1904 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1905 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1907 build_empty_stmt (loc
));
1908 gfc_add_expr_to_block (&body
, tmp
);
1911 /* Evaluate the loop condition. */
1912 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, dovar
,
1914 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1916 /* Increment the loop variable. */
1917 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1918 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1920 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1921 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1923 /* The loop exit. */
1924 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1925 TREE_USED (exit_label
) = 1;
1926 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1927 cond
, tmp
, build_empty_stmt (loc
));
1928 gfc_add_expr_to_block (&body
, tmp
);
1930 /* Finish the loop body. */
1931 tmp
= gfc_finish_block (&body
);
1932 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1934 /* Only execute the loop if the number of iterations is positive. */
1935 if (tree_int_cst_sgn (step
) > 0)
1936 cond
= fold_build2_loc (loc
, LE_EXPR
, boolean_type_node
, dovar
,
1939 cond
= fold_build2_loc (loc
, GE_EXPR
, boolean_type_node
, dovar
,
1942 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1943 gfc_likely (cond
, PRED_FORTRAN_LOOP_PREHEADER
), tmp
,
1944 build_empty_stmt (loc
));
1945 gfc_add_expr_to_block (pblock
, tmp
);
1947 /* Add the exit label. */
1948 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1949 gfc_add_expr_to_block (pblock
, tmp
);
1951 return gfc_finish_block (pblock
);
1954 /* Translate the DO construct. This obviously is one of the most
1955 important ones to get right with any compiler, but especially
1958 We special case some loop forms as described in gfc_trans_simple_do.
1959 For other cases we implement them with a separate loop count,
1960 as described in the standard.
1962 We translate a do loop from:
1964 DO dovar = from, to, step
1970 [evaluate loop bounds and step]
1971 empty = (step > 0 ? to < from : to > from);
1972 countm1 = (to - from) / step;
1974 if (empty) goto exit_label;
1982 if (countm1t == 0) goto exit_label;
1986 countm1 is an unsigned integer. It is equal to the loop count minus one,
1987 because the loop count itself can overflow. */
1990 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
1994 tree saved_dovar
= NULL
;
2009 gfc_start_block (&block
);
2011 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2013 /* Evaluate all the expressions in the iterator. */
2014 gfc_init_se (&se
, NULL
);
2015 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2016 gfc_add_block_to_block (&block
, &se
.pre
);
2018 type
= TREE_TYPE (dovar
);
2020 gfc_init_se (&se
, NULL
);
2021 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2022 gfc_add_block_to_block (&block
, &se
.pre
);
2023 from
= gfc_evaluate_now (se
.expr
, &block
);
2025 gfc_init_se (&se
, NULL
);
2026 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2027 gfc_add_block_to_block (&block
, &se
.pre
);
2028 to
= gfc_evaluate_now (se
.expr
, &block
);
2030 gfc_init_se (&se
, NULL
);
2031 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2032 gfc_add_block_to_block (&block
, &se
.pre
);
2033 step
= gfc_evaluate_now (se
.expr
, &block
);
2035 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2037 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
2038 build_zero_cst (type
));
2039 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2040 "DO step value is zero");
2043 /* Special case simple loops. */
2044 if (TREE_CODE (type
) == INTEGER_TYPE
2045 && (integer_onep (step
)
2046 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2047 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
, exit_cond
);
2050 if (TREE_CODE (type
) == INTEGER_TYPE
)
2051 utype
= unsigned_type_for (type
);
2053 utype
= unsigned_type_for (gfc_array_index_type
);
2054 countm1
= gfc_create_var (utype
, "countm1");
2056 /* Cycle and exit statements are implemented with gotos. */
2057 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2058 exit_label
= gfc_build_label_decl (NULL_TREE
);
2059 TREE_USED (exit_label
) = 1;
2061 /* Put these labels where they can be found later. */
2062 code
->cycle_label
= cycle_label
;
2063 code
->exit_label
= exit_label
;
2065 /* Initialize the DO variable: dovar = from. */
2066 gfc_add_modify (&block
, dovar
, from
);
2068 /* Save value for do-tinkering checking. */
2069 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2071 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2072 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2075 /* Initialize loop count and jump to exit label if the loop is empty.
2076 This code is executed before we enter the loop body. We generate:
2079 countm1 = (to - from) / step;
2085 countm1 = (from - to) / -step;
2091 if (TREE_CODE (type
) == INTEGER_TYPE
)
2093 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2095 /* The distance from FROM to TO cannot always be represented in a signed
2096 type, thus use unsigned arithmetic, also to avoid any undefined
2098 tou
= fold_convert (utype
, to
);
2099 fromu
= fold_convert (utype
, from
);
2100 stepu
= fold_convert (utype
, step
);
2102 /* For a positive step, when to < from, exit, otherwise compute
2103 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2104 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
2105 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2106 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2109 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2110 fold_build2 (MODIFY_EXPR
, void_type_node
,
2112 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2113 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2114 exit_label
), NULL_TREE
));
2116 /* For a negative step, when to > from, exit, otherwise compute
2117 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2118 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
2119 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2120 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2122 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2123 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2124 fold_build2 (MODIFY_EXPR
, void_type_node
,
2126 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2127 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2128 exit_label
), NULL_TREE
));
2130 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
2131 build_int_cst (TREE_TYPE (step
), 0));
2132 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2134 gfc_add_expr_to_block (&block
, tmp
);
2140 /* TODO: We could use the same width as the real type.
2141 This would probably cause more problems that it solves
2142 when we implement "long double" types. */
2144 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2145 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2146 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2147 gfc_add_modify (&block
, countm1
, tmp
);
2149 /* We need a special check for empty loops:
2150 empty = (step > 0 ? to < from : to > from); */
2151 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
2152 build_zero_cst (type
));
2153 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
2154 fold_build2_loc (loc
, LT_EXPR
,
2155 boolean_type_node
, to
, from
),
2156 fold_build2_loc (loc
, GT_EXPR
,
2157 boolean_type_node
, to
, from
));
2158 /* If the loop is empty, go directly to the exit label. */
2159 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2160 build1_v (GOTO_EXPR
, exit_label
),
2161 build_empty_stmt (input_location
));
2162 gfc_add_expr_to_block (&block
, tmp
);
2166 gfc_start_block (&body
);
2168 /* Main loop body. */
2169 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2170 gfc_add_expr_to_block (&body
, tmp
);
2172 /* Label for cycle statements (if needed). */
2173 if (TREE_USED (cycle_label
))
2175 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2176 gfc_add_expr_to_block (&body
, tmp
);
2179 /* Check whether someone has modified the loop variable. */
2180 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2182 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
2184 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2185 "Loop variable has been modified");
2188 /* Exit the loop if there is an I/O result condition or error. */
2191 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2192 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2194 build_empty_stmt (input_location
));
2195 gfc_add_expr_to_block (&body
, tmp
);
2198 /* Increment the loop variable. */
2199 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2200 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2202 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2203 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2205 /* Initialize countm1t. */
2206 tree countm1t
= gfc_create_var (utype
, "countm1t");
2207 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2209 /* Decrement the loop count. */
2210 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2211 build_int_cst (utype
, 1));
2212 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2214 /* End with the loop condition. Loop until countm1t == 0. */
2215 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
2216 build_int_cst (utype
, 0));
2217 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2218 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2219 cond
, tmp
, build_empty_stmt (loc
));
2220 gfc_add_expr_to_block (&body
, tmp
);
2222 /* End of loop body. */
2223 tmp
= gfc_finish_block (&body
);
2225 /* The for loop itself. */
2226 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2227 gfc_add_expr_to_block (&block
, tmp
);
2229 /* Add the exit label. */
2230 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2231 gfc_add_expr_to_block (&block
, tmp
);
2233 return gfc_finish_block (&block
);
2237 /* Translate the DO WHILE construct.
2250 if (! cond) goto exit_label;
2256 Because the evaluation of the exit condition `cond' may have side
2257 effects, we can't do much for empty loop bodies. The backend optimizers
2258 should be smart enough to eliminate any dead loops. */
2261 gfc_trans_do_while (gfc_code
* code
)
2269 /* Everything we build here is part of the loop body. */
2270 gfc_start_block (&block
);
2272 /* Cycle and exit statements are implemented with gotos. */
2273 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2274 exit_label
= gfc_build_label_decl (NULL_TREE
);
2276 /* Put the labels where they can be found later. See gfc_trans_do(). */
2277 code
->cycle_label
= cycle_label
;
2278 code
->exit_label
= exit_label
;
2280 /* Create a GIMPLE version of the exit condition. */
2281 gfc_init_se (&cond
, NULL
);
2282 gfc_conv_expr_val (&cond
, code
->expr1
);
2283 gfc_add_block_to_block (&block
, &cond
.pre
);
2284 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2285 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2287 /* Build "IF (! cond) GOTO exit_label". */
2288 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2289 TREE_USED (exit_label
) = 1;
2290 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2291 void_type_node
, cond
.expr
, tmp
,
2292 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2293 gfc_add_expr_to_block (&block
, tmp
);
2295 /* The main body of the loop. */
2296 tmp
= gfc_trans_code (code
->block
->next
);
2297 gfc_add_expr_to_block (&block
, tmp
);
2299 /* Label for cycle statements (if needed). */
2300 if (TREE_USED (cycle_label
))
2302 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2303 gfc_add_expr_to_block (&block
, tmp
);
2306 /* End of loop body. */
2307 tmp
= gfc_finish_block (&block
);
2309 gfc_init_block (&block
);
2310 /* Build the loop. */
2311 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2312 void_type_node
, tmp
);
2313 gfc_add_expr_to_block (&block
, tmp
);
2315 /* Add the exit label. */
2316 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2317 gfc_add_expr_to_block (&block
, tmp
);
2319 return gfc_finish_block (&block
);
2323 /* Translate the SELECT CASE construct for INTEGER case expressions,
2324 without killing all potential optimizations. The problem is that
2325 Fortran allows unbounded cases, but the back-end does not, so we
2326 need to intercept those before we enter the equivalent SWITCH_EXPR
2329 For example, we translate this,
2332 CASE (:100,101,105:115)
2342 to the GENERIC equivalent,
2346 case (minimum value for typeof(expr) ... 100:
2352 case 200 ... (maximum value for typeof(expr):
2369 gfc_trans_integer_select (gfc_code
* code
)
2379 gfc_start_block (&block
);
2381 /* Calculate the switch expression. */
2382 gfc_init_se (&se
, NULL
);
2383 gfc_conv_expr_val (&se
, code
->expr1
);
2384 gfc_add_block_to_block (&block
, &se
.pre
);
2386 end_label
= gfc_build_label_decl (NULL_TREE
);
2388 gfc_init_block (&body
);
2390 for (c
= code
->block
; c
; c
= c
->block
)
2392 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2397 /* Assume it's the default case. */
2398 low
= high
= NULL_TREE
;
2402 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2405 /* If there's only a lower bound, set the high bound to the
2406 maximum value of the case expression. */
2408 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2413 /* Three cases are possible here:
2415 1) There is no lower bound, e.g. CASE (:N).
2416 2) There is a lower bound .NE. high bound, that is
2417 a case range, e.g. CASE (N:M) where M>N (we make
2418 sure that M>N during type resolution).
2419 3) There is a lower bound, and it has the same value
2420 as the high bound, e.g. CASE (N:N). This is our
2421 internal representation of CASE(N).
2423 In the first and second case, we need to set a value for
2424 high. In the third case, we don't because the GCC middle
2425 end represents a single case value by just letting high be
2426 a NULL_TREE. We can't do that because we need to be able
2427 to represent unbounded cases. */
2431 && mpz_cmp (cp
->low
->value
.integer
,
2432 cp
->high
->value
.integer
) != 0))
2433 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2436 /* Unbounded case. */
2438 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2441 /* Build a label. */
2442 label
= gfc_build_label_decl (NULL_TREE
);
2444 /* Add this case label.
2445 Add parameter 'label', make it match GCC backend. */
2446 tmp
= build_case_label (low
, high
, label
);
2447 gfc_add_expr_to_block (&body
, tmp
);
2450 /* Add the statements for this case. */
2451 tmp
= gfc_trans_code (c
->next
);
2452 gfc_add_expr_to_block (&body
, tmp
);
2454 /* Break to the end of the construct. */
2455 tmp
= build1_v (GOTO_EXPR
, end_label
);
2456 gfc_add_expr_to_block (&body
, tmp
);
2459 tmp
= gfc_finish_block (&body
);
2460 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2461 se
.expr
, tmp
, NULL_TREE
);
2462 gfc_add_expr_to_block (&block
, tmp
);
2464 tmp
= build1_v (LABEL_EXPR
, end_label
);
2465 gfc_add_expr_to_block (&block
, tmp
);
2467 return gfc_finish_block (&block
);
2471 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2473 There are only two cases possible here, even though the standard
2474 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2475 .FALSE., and DEFAULT.
2477 We never generate more than two blocks here. Instead, we always
2478 try to eliminate the DEFAULT case. This way, we can translate this
2479 kind of SELECT construct to a simple
2483 expression in GENERIC. */
2486 gfc_trans_logical_select (gfc_code
* code
)
2489 gfc_code
*t
, *f
, *d
;
2494 /* Assume we don't have any cases at all. */
2497 /* Now see which ones we actually do have. We can have at most two
2498 cases in a single case list: one for .TRUE. and one for .FALSE.
2499 The default case is always separate. If the cases for .TRUE. and
2500 .FALSE. are in the same case list, the block for that case list
2501 always executed, and we don't generate code a COND_EXPR. */
2502 for (c
= code
->block
; c
; c
= c
->block
)
2504 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2508 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2510 else /* if (cp->value.logical != 0), thus .TRUE. */
2518 /* Start a new block. */
2519 gfc_start_block (&block
);
2521 /* Calculate the switch expression. We always need to do this
2522 because it may have side effects. */
2523 gfc_init_se (&se
, NULL
);
2524 gfc_conv_expr_val (&se
, code
->expr1
);
2525 gfc_add_block_to_block (&block
, &se
.pre
);
2527 if (t
== f
&& t
!= NULL
)
2529 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2530 translate the code for these cases, append it to the current
2532 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2536 tree true_tree
, false_tree
, stmt
;
2538 true_tree
= build_empty_stmt (input_location
);
2539 false_tree
= build_empty_stmt (input_location
);
2541 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2542 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2543 make the missing case the default case. */
2544 if (t
!= NULL
&& f
!= NULL
)
2554 /* Translate the code for each of these blocks, and append it to
2555 the current block. */
2557 true_tree
= gfc_trans_code (t
->next
);
2560 false_tree
= gfc_trans_code (f
->next
);
2562 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2563 se
.expr
, true_tree
, false_tree
);
2564 gfc_add_expr_to_block (&block
, stmt
);
2567 return gfc_finish_block (&block
);
2571 /* The jump table types are stored in static variables to avoid
2572 constructing them from scratch every single time. */
2573 static GTY(()) tree select_struct
[2];
2575 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2576 Instead of generating compares and jumps, it is far simpler to
2577 generate a data structure describing the cases in order and call a
2578 library subroutine that locates the right case.
2579 This is particularly true because this is the only case where we
2580 might have to dispose of a temporary.
2581 The library subroutine returns a pointer to jump to or NULL if no
2582 branches are to be taken. */
2585 gfc_trans_character_select (gfc_code
*code
)
2587 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2588 stmtblock_t block
, body
;
2593 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2595 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2597 /* The jump table types are stored in static variables to avoid
2598 constructing them from scratch every single time. */
2599 static tree ss_string1
[2], ss_string1_len
[2];
2600 static tree ss_string2
[2], ss_string2_len
[2];
2601 static tree ss_target
[2];
2603 cp
= code
->block
->ext
.block
.case_list
;
2604 while (cp
->left
!= NULL
)
2607 /* Generate the body */
2608 gfc_start_block (&block
);
2609 gfc_init_se (&expr1se
, NULL
);
2610 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2612 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2614 end_label
= gfc_build_label_decl (NULL_TREE
);
2616 gfc_init_block (&body
);
2618 /* Attempt to optimize length 1 selects. */
2619 if (integer_onep (expr1se
.string_length
))
2621 for (d
= cp
; d
; d
= d
->right
)
2626 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2627 && d
->low
->ts
.type
== BT_CHARACTER
);
2628 if (d
->low
->value
.character
.length
> 1)
2630 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2631 if (d
->low
->value
.character
.string
[i
] != ' ')
2633 if (i
!= d
->low
->value
.character
.length
)
2635 if (optimize
&& d
->high
&& i
== 1)
2637 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2638 && d
->high
->ts
.type
== BT_CHARACTER
);
2639 if (d
->high
->value
.character
.length
> 1
2640 && (d
->low
->value
.character
.string
[0]
2641 == d
->high
->value
.character
.string
[0])
2642 && d
->high
->value
.character
.string
[1] != ' '
2643 && ((d
->low
->value
.character
.string
[1] < ' ')
2644 == (d
->high
->value
.character
.string
[1]
2654 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2655 && d
->high
->ts
.type
== BT_CHARACTER
);
2656 if (d
->high
->value
.character
.length
> 1)
2658 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2659 if (d
->high
->value
.character
.string
[i
] != ' ')
2661 if (i
!= d
->high
->value
.character
.length
)
2668 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2670 for (c
= code
->block
; c
; c
= c
->block
)
2672 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2678 /* Assume it's the default case. */
2679 low
= high
= NULL_TREE
;
2683 /* CASE ('ab') or CASE ('ab':'az') will never match
2684 any length 1 character. */
2685 if (cp
->low
->value
.character
.length
> 1
2686 && cp
->low
->value
.character
.string
[1] != ' ')
2689 if (cp
->low
->value
.character
.length
> 0)
2690 r
= cp
->low
->value
.character
.string
[0];
2693 low
= build_int_cst (ctype
, r
);
2695 /* If there's only a lower bound, set the high bound
2696 to the maximum value of the case expression. */
2698 high
= TYPE_MAX_VALUE (ctype
);
2704 || (cp
->low
->value
.character
.string
[0]
2705 != cp
->high
->value
.character
.string
[0]))
2707 if (cp
->high
->value
.character
.length
> 0)
2708 r
= cp
->high
->value
.character
.string
[0];
2711 high
= build_int_cst (ctype
, r
);
2714 /* Unbounded case. */
2716 low
= TYPE_MIN_VALUE (ctype
);
2719 /* Build a label. */
2720 label
= gfc_build_label_decl (NULL_TREE
);
2722 /* Add this case label.
2723 Add parameter 'label', make it match GCC backend. */
2724 tmp
= build_case_label (low
, high
, label
);
2725 gfc_add_expr_to_block (&body
, tmp
);
2728 /* Add the statements for this case. */
2729 tmp
= gfc_trans_code (c
->next
);
2730 gfc_add_expr_to_block (&body
, tmp
);
2732 /* Break to the end of the construct. */
2733 tmp
= build1_v (GOTO_EXPR
, end_label
);
2734 gfc_add_expr_to_block (&body
, tmp
);
2737 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2739 code
->expr1
->ts
.kind
);
2740 case_num
= gfc_create_var (ctype
, "case_num");
2741 gfc_add_modify (&block
, case_num
, tmp
);
2743 gfc_add_block_to_block (&block
, &expr1se
.post
);
2745 tmp
= gfc_finish_block (&body
);
2746 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2747 case_num
, tmp
, NULL_TREE
);
2748 gfc_add_expr_to_block (&block
, tmp
);
2750 tmp
= build1_v (LABEL_EXPR
, end_label
);
2751 gfc_add_expr_to_block (&block
, tmp
);
2753 return gfc_finish_block (&block
);
2757 if (code
->expr1
->ts
.kind
== 1)
2759 else if (code
->expr1
->ts
.kind
== 4)
2764 if (select_struct
[k
] == NULL
)
2767 select_struct
[k
] = make_node (RECORD_TYPE
);
2769 if (code
->expr1
->ts
.kind
== 1)
2770 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2771 else if (code
->expr1
->ts
.kind
== 4)
2772 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2777 #define ADD_FIELD(NAME, TYPE) \
2778 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2779 get_identifier (stringize(NAME)), \
2783 ADD_FIELD (string1
, pchartype
);
2784 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2786 ADD_FIELD (string2
, pchartype
);
2787 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2789 ADD_FIELD (target
, integer_type_node
);
2792 gfc_finish_type (select_struct
[k
]);
2796 for (d
= cp
; d
; d
= d
->right
)
2799 for (c
= code
->block
; c
; c
= c
->block
)
2801 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
2803 label
= gfc_build_label_decl (NULL_TREE
);
2804 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
2806 : build_int_cst (integer_type_node
, d
->n
),
2808 gfc_add_expr_to_block (&body
, tmp
);
2811 tmp
= gfc_trans_code (c
->next
);
2812 gfc_add_expr_to_block (&body
, tmp
);
2814 tmp
= build1_v (GOTO_EXPR
, end_label
);
2815 gfc_add_expr_to_block (&body
, tmp
);
2818 /* Generate the structure describing the branches */
2819 for (d
= cp
; d
; d
= d
->right
)
2821 vec
<constructor_elt
, va_gc
> *node
= NULL
;
2823 gfc_init_se (&se
, NULL
);
2827 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
2828 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
2832 gfc_conv_expr_reference (&se
, d
->low
);
2834 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
2835 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
2838 if (d
->high
== NULL
)
2840 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
2841 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
2845 gfc_init_se (&se
, NULL
);
2846 gfc_conv_expr_reference (&se
, d
->high
);
2848 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
2849 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
2852 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
2853 build_int_cst (integer_type_node
, d
->n
));
2855 tmp
= build_constructor (select_struct
[k
], node
);
2856 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
2859 type
= build_array_type (select_struct
[k
],
2860 build_index_type (size_int (n
-1)));
2862 init
= build_constructor (type
, inits
);
2863 TREE_CONSTANT (init
) = 1;
2864 TREE_STATIC (init
) = 1;
2865 /* Create a static variable to hold the jump table. */
2866 tmp
= gfc_create_var (type
, "jumptable");
2867 TREE_CONSTANT (tmp
) = 1;
2868 TREE_STATIC (tmp
) = 1;
2869 TREE_READONLY (tmp
) = 1;
2870 DECL_INITIAL (tmp
) = init
;
2873 /* Build the library call */
2874 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
2876 if (code
->expr1
->ts
.kind
== 1)
2877 fndecl
= gfor_fndecl_select_string
;
2878 else if (code
->expr1
->ts
.kind
== 4)
2879 fndecl
= gfor_fndecl_select_string_char4
;
2883 tmp
= build_call_expr_loc (input_location
,
2885 build_int_cst (gfc_charlen_type_node
, n
),
2886 expr1se
.expr
, expr1se
.string_length
);
2887 case_num
= gfc_create_var (integer_type_node
, "case_num");
2888 gfc_add_modify (&block
, case_num
, tmp
);
2890 gfc_add_block_to_block (&block
, &expr1se
.post
);
2892 tmp
= gfc_finish_block (&body
);
2893 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2894 case_num
, tmp
, NULL_TREE
);
2895 gfc_add_expr_to_block (&block
, tmp
);
2897 tmp
= build1_v (LABEL_EXPR
, end_label
);
2898 gfc_add_expr_to_block (&block
, tmp
);
2900 return gfc_finish_block (&block
);
2904 /* Translate the three variants of the SELECT CASE construct.
2906 SELECT CASEs with INTEGER case expressions can be translated to an
2907 equivalent GENERIC switch statement, and for LOGICAL case
2908 expressions we build one or two if-else compares.
2910 SELECT CASEs with CHARACTER case expressions are a whole different
2911 story, because they don't exist in GENERIC. So we sort them and
2912 do a binary search at runtime.
2914 Fortran has no BREAK statement, and it does not allow jumps from
2915 one case block to another. That makes things a lot easier for
2919 gfc_trans_select (gfc_code
* code
)
2925 gcc_assert (code
&& code
->expr1
);
2926 gfc_init_block (&block
);
2928 /* Build the exit label and hang it in. */
2929 exit_label
= gfc_build_label_decl (NULL_TREE
);
2930 code
->exit_label
= exit_label
;
2932 /* Empty SELECT constructs are legal. */
2933 if (code
->block
== NULL
)
2934 body
= build_empty_stmt (input_location
);
2936 /* Select the correct translation function. */
2938 switch (code
->expr1
->ts
.type
)
2941 body
= gfc_trans_logical_select (code
);
2945 body
= gfc_trans_integer_select (code
);
2949 body
= gfc_trans_character_select (code
);
2953 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2957 /* Build everything together. */
2958 gfc_add_expr_to_block (&block
, body
);
2959 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
2961 return gfc_finish_block (&block
);
2965 /* Traversal function to substitute a replacement symtree if the symbol
2966 in the expression is the same as that passed. f == 2 signals that
2967 that variable itself is not to be checked - only the references.
2968 This group of functions is used when the variable expression in a
2969 FORALL assignment has internal references. For example:
2970 FORALL (i = 1:4) p(p(i)) = i
2971 The only recourse here is to store a copy of 'p' for the index
2974 static gfc_symtree
*new_symtree
;
2975 static gfc_symtree
*old_symtree
;
2978 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
2980 if (expr
->expr_type
!= EXPR_VARIABLE
)
2985 else if (expr
->symtree
->n
.sym
== sym
)
2986 expr
->symtree
= new_symtree
;
2992 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
2994 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
2998 forall_restore (gfc_expr
*expr
,
2999 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3000 int *f ATTRIBUTE_UNUSED
)
3002 if (expr
->expr_type
!= EXPR_VARIABLE
)
3005 if (expr
->symtree
== new_symtree
)
3006 expr
->symtree
= old_symtree
;
3012 forall_restore_symtree (gfc_expr
*e
)
3014 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3018 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3023 gfc_symbol
*new_sym
;
3024 gfc_symbol
*old_sym
;
3028 /* Build a copy of the lvalue. */
3029 old_symtree
= c
->expr1
->symtree
;
3030 old_sym
= old_symtree
->n
.sym
;
3031 e
= gfc_lval_expr_from_sym (old_sym
);
3032 if (old_sym
->attr
.dimension
)
3034 gfc_init_se (&tse
, NULL
);
3035 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3036 gfc_add_block_to_block (pre
, &tse
.pre
);
3037 gfc_add_block_to_block (post
, &tse
.post
);
3038 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3040 if (e
->ts
.type
!= BT_CHARACTER
)
3042 /* Use the variable offset for the temporary. */
3043 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3044 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3049 gfc_init_se (&tse
, NULL
);
3050 gfc_init_se (&rse
, NULL
);
3051 gfc_conv_expr (&rse
, e
);
3052 if (e
->ts
.type
== BT_CHARACTER
)
3054 tse
.string_length
= rse
.string_length
;
3055 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3057 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3059 gfc_add_block_to_block (pre
, &tse
.pre
);
3060 gfc_add_block_to_block (post
, &tse
.post
);
3064 tmp
= gfc_typenode_for_spec (&e
->ts
);
3065 tse
.expr
= gfc_create_var (tmp
, "temp");
3068 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3069 e
->expr_type
== EXPR_VARIABLE
, false);
3070 gfc_add_expr_to_block (pre
, tmp
);
3074 /* Create a new symbol to represent the lvalue. */
3075 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3076 new_sym
->ts
= old_sym
->ts
;
3077 new_sym
->attr
.referenced
= 1;
3078 new_sym
->attr
.temporary
= 1;
3079 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3080 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3082 /* Use the temporary as the backend_decl. */
3083 new_sym
->backend_decl
= tse
.expr
;
3085 /* Create a fake symtree for it. */
3087 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3088 new_symtree
->n
.sym
= new_sym
;
3089 gcc_assert (new_symtree
== root
);
3091 /* Go through the expression reference replacing the old_symtree
3093 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3095 /* Now we have made this temporary, we might as well use it for
3096 the right hand side. */
3097 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3101 /* Handles dependencies in forall assignments. */
3103 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3110 lsym
= c
->expr1
->symtree
->n
.sym
;
3111 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3113 /* Now check for dependencies within the 'variable'
3114 expression itself. These are treated by making a complete
3115 copy of variable and changing all the references to it
3116 point to the copy instead. Note that the shallow copy of
3117 the variable will not suffice for derived types with
3118 pointer components. We therefore leave these to their
3120 if (lsym
->ts
.type
== BT_DERIVED
3121 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3125 if (find_forall_index (c
->expr1
, lsym
, 2))
3127 forall_make_variable_temp (c
, pre
, post
);
3131 /* Substrings with dependencies are treated in the same
3133 if (c
->expr1
->ts
.type
== BT_CHARACTER
3135 && c
->expr2
->expr_type
== EXPR_VARIABLE
3136 && lsym
== c
->expr2
->symtree
->n
.sym
)
3138 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3139 if (lref
->type
== REF_SUBSTRING
)
3141 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3142 if (rref
->type
== REF_SUBSTRING
)
3146 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3148 forall_make_variable_temp (c
, pre
, post
);
3157 cleanup_forall_symtrees (gfc_code
*c
)
3159 forall_restore_symtree (c
->expr1
);
3160 forall_restore_symtree (c
->expr2
);
3161 free (new_symtree
->n
.sym
);
3166 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3167 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3168 indicates whether we should generate code to test the FORALLs mask
3169 array. OUTER is the loop header to be used for initializing mask
3172 The generated loop format is:
3173 count = (end - start + step) / step
3186 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3187 int mask_flag
, stmtblock_t
*outer
)
3195 tree var
, start
, end
, step
;
3198 /* Initialize the mask index outside the FORALL nest. */
3199 if (mask_flag
&& forall_tmp
->mask
)
3200 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3202 iter
= forall_tmp
->this_loop
;
3203 nvar
= forall_tmp
->nvar
;
3204 for (n
= 0; n
< nvar
; n
++)
3207 start
= iter
->start
;
3211 exit_label
= gfc_build_label_decl (NULL_TREE
);
3212 TREE_USED (exit_label
) = 1;
3214 /* The loop counter. */
3215 count
= gfc_create_var (TREE_TYPE (var
), "count");
3217 /* The body of the loop. */
3218 gfc_init_block (&block
);
3220 /* The exit condition. */
3221 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3222 count
, build_int_cst (TREE_TYPE (count
), 0));
3223 if (forall_tmp
->do_concurrent
)
3224 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3225 build_int_cst (integer_type_node
,
3226 annot_expr_ivdep_kind
));
3228 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3229 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3230 cond
, tmp
, build_empty_stmt (input_location
));
3231 gfc_add_expr_to_block (&block
, tmp
);
3233 /* The main loop body. */
3234 gfc_add_expr_to_block (&block
, body
);
3236 /* Increment the loop variable. */
3237 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3239 gfc_add_modify (&block
, var
, tmp
);
3241 /* Advance to the next mask element. Only do this for the
3243 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3245 tree maskindex
= forall_tmp
->maskindex
;
3246 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3247 maskindex
, gfc_index_one_node
);
3248 gfc_add_modify (&block
, maskindex
, tmp
);
3251 /* Decrement the loop counter. */
3252 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3253 build_int_cst (TREE_TYPE (var
), 1));
3254 gfc_add_modify (&block
, count
, tmp
);
3256 body
= gfc_finish_block (&block
);
3258 /* Loop var initialization. */
3259 gfc_init_block (&block
);
3260 gfc_add_modify (&block
, var
, start
);
3263 /* Initialize the loop counter. */
3264 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3266 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3268 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3270 gfc_add_modify (&block
, count
, tmp
);
3272 /* The loop expression. */
3273 tmp
= build1_v (LOOP_EXPR
, body
);
3274 gfc_add_expr_to_block (&block
, tmp
);
3276 /* The exit label. */
3277 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3278 gfc_add_expr_to_block (&block
, tmp
);
3280 body
= gfc_finish_block (&block
);
3287 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3288 is nonzero, the body is controlled by all masks in the forall nest.
3289 Otherwise, the innermost loop is not controlled by it's mask. This
3290 is used for initializing that mask. */
3293 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3298 forall_info
*forall_tmp
;
3299 tree mask
, maskindex
;
3301 gfc_start_block (&header
);
3303 forall_tmp
= nested_forall_info
;
3304 while (forall_tmp
!= NULL
)
3306 /* Generate body with masks' control. */
3309 mask
= forall_tmp
->mask
;
3310 maskindex
= forall_tmp
->maskindex
;
3312 /* If a mask was specified make the assignment conditional. */
3315 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3316 body
= build3_v (COND_EXPR
, tmp
, body
,
3317 build_empty_stmt (input_location
));
3320 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3321 forall_tmp
= forall_tmp
->prev_nest
;
3325 gfc_add_expr_to_block (&header
, body
);
3326 return gfc_finish_block (&header
);
3330 /* Allocate data for holding a temporary array. Returns either a local
3331 temporary array or a pointer variable. */
3334 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3341 if (INTEGER_CST_P (size
))
3342 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3343 size
, gfc_index_one_node
);
3347 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3348 type
= build_array_type (elem_type
, type
);
3349 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3351 tmpvar
= gfc_create_var (type
, "temp");
3356 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3357 *pdata
= convert (pvoid_type_node
, tmpvar
);
3359 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3360 gfc_add_modify (pblock
, tmpvar
, tmp
);
3366 /* Generate codes to copy the temporary to the actual lhs. */
3369 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3370 tree count1
, tree wheremask
, bool invert
)
3374 stmtblock_t block
, body
;
3380 lss
= gfc_walk_expr (expr
);
3382 if (lss
== gfc_ss_terminator
)
3384 gfc_start_block (&block
);
3386 gfc_init_se (&lse
, NULL
);
3388 /* Translate the expression. */
3389 gfc_conv_expr (&lse
, expr
);
3391 /* Form the expression for the temporary. */
3392 tmp
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3394 /* Use the scalar assignment as is. */
3395 gfc_add_block_to_block (&block
, &lse
.pre
);
3396 gfc_add_modify (&block
, lse
.expr
, tmp
);
3397 gfc_add_block_to_block (&block
, &lse
.post
);
3399 /* Increment the count1. */
3400 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3401 count1
, gfc_index_one_node
);
3402 gfc_add_modify (&block
, count1
, tmp
);
3404 tmp
= gfc_finish_block (&block
);
3408 gfc_start_block (&block
);
3410 gfc_init_loopinfo (&loop1
);
3411 gfc_init_se (&rse
, NULL
);
3412 gfc_init_se (&lse
, NULL
);
3414 /* Associate the lss with the loop. */
3415 gfc_add_ss_to_loop (&loop1
, lss
);
3417 /* Calculate the bounds of the scalarization. */
3418 gfc_conv_ss_startstride (&loop1
);
3419 /* Setup the scalarizing loops. */
3420 gfc_conv_loop_setup (&loop1
, &expr
->where
);
3422 gfc_mark_ss_chain_used (lss
, 1);
3424 /* Start the scalarized loop body. */
3425 gfc_start_scalarized_body (&loop1
, &body
);
3427 /* Setup the gfc_se structures. */
3428 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
3431 /* Form the expression of the temporary. */
3432 if (lss
!= gfc_ss_terminator
)
3433 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3434 /* Translate expr. */
3435 gfc_conv_expr (&lse
, expr
);
3437 /* Use the scalar assignment. */
3438 rse
.string_length
= lse
.string_length
;
3439 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, true);
3441 /* Form the mask expression according to the mask tree list. */
3444 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3446 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3447 TREE_TYPE (wheremaskexpr
),
3449 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3451 build_empty_stmt (input_location
));
3454 gfc_add_expr_to_block (&body
, tmp
);
3456 /* Increment count1. */
3457 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3458 count1
, gfc_index_one_node
);
3459 gfc_add_modify (&body
, count1
, tmp
);
3461 /* Increment count3. */
3464 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3465 gfc_array_index_type
, count3
,
3466 gfc_index_one_node
);
3467 gfc_add_modify (&body
, count3
, tmp
);
3470 /* Generate the copying loops. */
3471 gfc_trans_scalarizing_loops (&loop1
, &body
);
3472 gfc_add_block_to_block (&block
, &loop1
.pre
);
3473 gfc_add_block_to_block (&block
, &loop1
.post
);
3474 gfc_cleanup_loop (&loop1
);
3476 tmp
= gfc_finish_block (&block
);
3482 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3483 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3484 and should not be freed. WHEREMASK is the conditional execution mask
3485 whose sense may be inverted by INVERT. */
3488 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3489 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3490 tree wheremask
, bool invert
)
3492 stmtblock_t block
, body1
;
3499 gfc_start_block (&block
);
3501 gfc_init_se (&rse
, NULL
);
3502 gfc_init_se (&lse
, NULL
);
3504 if (lss
== gfc_ss_terminator
)
3506 gfc_init_block (&body1
);
3507 gfc_conv_expr (&rse
, expr2
);
3508 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3512 /* Initialize the loop. */
3513 gfc_init_loopinfo (&loop
);
3515 /* We may need LSS to determine the shape of the expression. */
3516 gfc_add_ss_to_loop (&loop
, lss
);
3517 gfc_add_ss_to_loop (&loop
, rss
);
3519 gfc_conv_ss_startstride (&loop
);
3520 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3522 gfc_mark_ss_chain_used (rss
, 1);
3523 /* Start the loop body. */
3524 gfc_start_scalarized_body (&loop
, &body1
);
3526 /* Translate the expression. */
3527 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3529 gfc_conv_expr (&rse
, expr2
);
3531 /* Form the expression of the temporary. */
3532 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3535 /* Use the scalar assignment. */
3536 lse
.string_length
= rse
.string_length
;
3537 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3538 expr2
->expr_type
== EXPR_VARIABLE
, false);
3540 /* Form the mask expression according to the mask tree list. */
3543 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3545 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3546 TREE_TYPE (wheremaskexpr
),
3548 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3550 build_empty_stmt (input_location
));
3553 gfc_add_expr_to_block (&body1
, tmp
);
3555 if (lss
== gfc_ss_terminator
)
3557 gfc_add_block_to_block (&block
, &body1
);
3559 /* Increment count1. */
3560 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3561 count1
, gfc_index_one_node
);
3562 gfc_add_modify (&block
, count1
, tmp
);
3566 /* Increment count1. */
3567 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3568 count1
, gfc_index_one_node
);
3569 gfc_add_modify (&body1
, count1
, tmp
);
3571 /* Increment count3. */
3574 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3575 gfc_array_index_type
,
3576 count3
, gfc_index_one_node
);
3577 gfc_add_modify (&body1
, count3
, tmp
);
3580 /* Generate the copying loops. */
3581 gfc_trans_scalarizing_loops (&loop
, &body1
);
3583 gfc_add_block_to_block (&block
, &loop
.pre
);
3584 gfc_add_block_to_block (&block
, &loop
.post
);
3586 gfc_cleanup_loop (&loop
);
3587 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3588 as tree nodes in SS may not be valid in different scope. */
3591 tmp
= gfc_finish_block (&block
);
3596 /* Calculate the size of temporary needed in the assignment inside forall.
3597 LSS and RSS are filled in this function. */
3600 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3601 stmtblock_t
* pblock
,
3602 gfc_ss
**lss
, gfc_ss
**rss
)
3610 *lss
= gfc_walk_expr (expr1
);
3613 size
= gfc_index_one_node
;
3614 if (*lss
!= gfc_ss_terminator
)
3616 gfc_init_loopinfo (&loop
);
3618 /* Walk the RHS of the expression. */
3619 *rss
= gfc_walk_expr (expr2
);
3620 if (*rss
== gfc_ss_terminator
)
3621 /* The rhs is scalar. Add a ss for the expression. */
3622 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3624 /* Associate the SS with the loop. */
3625 gfc_add_ss_to_loop (&loop
, *lss
);
3626 /* We don't actually need to add the rhs at this point, but it might
3627 make guessing the loop bounds a bit easier. */
3628 gfc_add_ss_to_loop (&loop
, *rss
);
3630 /* We only want the shape of the expression, not rest of the junk
3631 generated by the scalarizer. */
3632 loop
.array_parameter
= 1;
3634 /* Calculate the bounds of the scalarization. */
3635 save_flag
= gfc_option
.rtcheck
;
3636 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3637 gfc_conv_ss_startstride (&loop
);
3638 gfc_option
.rtcheck
= save_flag
;
3639 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3641 /* Figure out how many elements we need. */
3642 for (i
= 0; i
< loop
.dimen
; i
++)
3644 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3645 gfc_array_index_type
,
3646 gfc_index_one_node
, loop
.from
[i
]);
3647 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3648 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3649 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3650 gfc_array_index_type
, size
, tmp
);
3652 gfc_add_block_to_block (pblock
, &loop
.pre
);
3653 size
= gfc_evaluate_now (size
, pblock
);
3654 gfc_add_block_to_block (pblock
, &loop
.post
);
3656 /* TODO: write a function that cleans up a loopinfo without freeing
3657 the SS chains. Currently a NOP. */
3664 /* Calculate the overall iterator number of the nested forall construct.
3665 This routine actually calculates the number of times the body of the
3666 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3667 that by the expression INNER_SIZE. The BLOCK argument specifies the
3668 block in which to calculate the result, and the optional INNER_SIZE_BODY
3669 argument contains any statements that need to executed (inside the loop)
3670 to initialize or calculate INNER_SIZE. */
3673 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3674 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3676 forall_info
*forall_tmp
= nested_forall_info
;
3680 /* We can eliminate the innermost unconditional loops with constant
3682 if (INTEGER_CST_P (inner_size
))
3685 && !forall_tmp
->mask
3686 && INTEGER_CST_P (forall_tmp
->size
))
3688 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3689 gfc_array_index_type
,
3690 inner_size
, forall_tmp
->size
);
3691 forall_tmp
= forall_tmp
->prev_nest
;
3694 /* If there are no loops left, we have our constant result. */
3699 /* Otherwise, create a temporary variable to compute the result. */
3700 number
= gfc_create_var (gfc_array_index_type
, "num");
3701 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3703 gfc_start_block (&body
);
3704 if (inner_size_body
)
3705 gfc_add_block_to_block (&body
, inner_size_body
);
3707 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3708 gfc_array_index_type
, number
, inner_size
);
3711 gfc_add_modify (&body
, number
, tmp
);
3712 tmp
= gfc_finish_block (&body
);
3714 /* Generate loops. */
3715 if (forall_tmp
!= NULL
)
3716 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3718 gfc_add_expr_to_block (block
, tmp
);
3724 /* Allocate temporary for forall construct. SIZE is the size of temporary
3725 needed. PTEMP1 is returned for space free. */
3728 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3735 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3736 if (!integer_onep (unit
))
3737 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3738 gfc_array_index_type
, size
, unit
);
3743 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3746 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3751 /* Allocate temporary for forall construct according to the information in
3752 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3753 assignment inside forall. PTEMP1 is returned for space free. */
3756 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3757 tree inner_size
, stmtblock_t
* inner_size_body
,
3758 stmtblock_t
* block
, tree
* ptemp1
)
3762 /* Calculate the total size of temporary needed in forall construct. */
3763 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3764 inner_size_body
, block
);
3766 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3770 /* Handle assignments inside forall which need temporary.
3772 forall (i=start:end:stride; maskexpr)
3775 (where e,f<i> are arbitrary expressions possibly involving i
3776 and there is a dependency between e<i> and f<i>)
3778 masktmp(:) = maskexpr(:)
3783 for (i = start; i <= end; i += stride)
3787 for (i = start; i <= end; i += stride)
3789 if (masktmp[maskindex++])
3790 tmp[count1++] = f<i>
3794 for (i = start; i <= end; i += stride)
3796 if (masktmp[maskindex++])
3797 e<i> = tmp[count1++]
3802 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3803 tree wheremask
, bool invert
,
3804 forall_info
* nested_forall_info
,
3805 stmtblock_t
* block
)
3813 stmtblock_t inner_size_body
;
3815 /* Create vars. count1 is the current iterator number of the nested
3817 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3819 /* Count is the wheremask index. */
3822 count
= gfc_create_var (gfc_array_index_type
, "count");
3823 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3828 /* Initialize count1. */
3829 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3831 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3832 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3833 gfc_init_block (&inner_size_body
);
3834 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
3837 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3838 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->length
)
3840 if (!expr1
->ts
.u
.cl
->backend_decl
)
3843 gfc_init_se (&tse
, NULL
);
3844 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
3845 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
3847 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3848 expr1
->ts
.u
.cl
->backend_decl
);
3851 type
= gfc_typenode_for_spec (&expr1
->ts
);
3853 /* Allocate temporary for nested forall construct according to the
3854 information in nested_forall_info and inner_size. */
3855 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
3856 &inner_size_body
, block
, &ptemp1
);
3858 /* Generate codes to copy rhs to the temporary . */
3859 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
3862 /* Generate body and loops according to the information in
3863 nested_forall_info. */
3864 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3865 gfc_add_expr_to_block (block
, tmp
);
3868 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3872 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3874 /* Generate codes to copy the temporary to lhs. */
3875 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
3878 /* Generate body and loops according to the information in
3879 nested_forall_info. */
3880 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3881 gfc_add_expr_to_block (block
, tmp
);
3885 /* Free the temporary. */
3886 tmp
= gfc_call_free (ptemp1
);
3887 gfc_add_expr_to_block (block
, tmp
);
3892 /* Translate pointer assignment inside FORALL which need temporary. */
3895 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3896 forall_info
* nested_forall_info
,
3897 stmtblock_t
* block
)
3904 gfc_array_info
*info
;
3911 tree tmp
, tmp1
, ptemp1
;
3913 count
= gfc_create_var (gfc_array_index_type
, "count");
3914 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3916 inner_size
= gfc_index_one_node
;
3917 lss
= gfc_walk_expr (expr1
);
3918 rss
= gfc_walk_expr (expr2
);
3919 if (lss
== gfc_ss_terminator
)
3921 type
= gfc_typenode_for_spec (&expr1
->ts
);
3922 type
= build_pointer_type (type
);
3924 /* Allocate temporary for nested forall construct according to the
3925 information in nested_forall_info and inner_size. */
3926 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
3927 inner_size
, NULL
, block
, &ptemp1
);
3928 gfc_start_block (&body
);
3929 gfc_init_se (&lse
, NULL
);
3930 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3931 gfc_init_se (&rse
, NULL
);
3932 rse
.want_pointer
= 1;
3933 gfc_conv_expr (&rse
, expr2
);
3934 gfc_add_block_to_block (&body
, &rse
.pre
);
3935 gfc_add_modify (&body
, lse
.expr
,
3936 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3937 gfc_add_block_to_block (&body
, &rse
.post
);
3939 /* Increment count. */
3940 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3941 count
, gfc_index_one_node
);
3942 gfc_add_modify (&body
, count
, tmp
);
3944 tmp
= gfc_finish_block (&body
);
3946 /* Generate body and loops according to the information in
3947 nested_forall_info. */
3948 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3949 gfc_add_expr_to_block (block
, tmp
);
3952 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3954 gfc_start_block (&body
);
3955 gfc_init_se (&lse
, NULL
);
3956 gfc_init_se (&rse
, NULL
);
3957 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3958 lse
.want_pointer
= 1;
3959 gfc_conv_expr (&lse
, expr1
);
3960 gfc_add_block_to_block (&body
, &lse
.pre
);
3961 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
3962 gfc_add_block_to_block (&body
, &lse
.post
);
3963 /* Increment count. */
3964 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3965 count
, gfc_index_one_node
);
3966 gfc_add_modify (&body
, count
, tmp
);
3967 tmp
= gfc_finish_block (&body
);
3969 /* Generate body and loops according to the information in
3970 nested_forall_info. */
3971 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3972 gfc_add_expr_to_block (block
, tmp
);
3976 gfc_init_loopinfo (&loop
);
3978 /* Associate the SS with the loop. */
3979 gfc_add_ss_to_loop (&loop
, rss
);
3981 /* Setup the scalarizing loops and bounds. */
3982 gfc_conv_ss_startstride (&loop
);
3984 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3986 info
= &rss
->info
->data
.array
;
3987 desc
= info
->descriptor
;
3989 /* Make a new descriptor. */
3990 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3991 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
3992 loop
.from
, loop
.to
, 1,
3993 GFC_ARRAY_UNKNOWN
, true);
3995 /* Allocate temporary for nested forall construct. */
3996 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
3997 inner_size
, NULL
, block
, &ptemp1
);
3998 gfc_start_block (&body
);
3999 gfc_init_se (&lse
, NULL
);
4000 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4001 lse
.direct_byref
= 1;
4002 gfc_conv_expr_descriptor (&lse
, expr2
);
4004 gfc_add_block_to_block (&body
, &lse
.pre
);
4005 gfc_add_block_to_block (&body
, &lse
.post
);
4007 /* Increment count. */
4008 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4009 count
, gfc_index_one_node
);
4010 gfc_add_modify (&body
, count
, tmp
);
4012 tmp
= gfc_finish_block (&body
);
4014 /* Generate body and loops according to the information in
4015 nested_forall_info. */
4016 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4017 gfc_add_expr_to_block (block
, tmp
);
4020 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4022 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4023 gfc_init_se (&lse
, NULL
);
4024 gfc_conv_expr_descriptor (&lse
, expr1
);
4025 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4026 gfc_start_block (&body
);
4027 gfc_add_block_to_block (&body
, &lse
.pre
);
4028 gfc_add_block_to_block (&body
, &lse
.post
);
4030 /* Increment count. */
4031 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4032 count
, gfc_index_one_node
);
4033 gfc_add_modify (&body
, count
, tmp
);
4035 tmp
= gfc_finish_block (&body
);
4037 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4038 gfc_add_expr_to_block (block
, tmp
);
4040 /* Free the temporary. */
4043 tmp
= gfc_call_free (ptemp1
);
4044 gfc_add_expr_to_block (block
, tmp
);
4049 /* FORALL and WHERE statements are really nasty, especially when you nest
4050 them. All the rhs of a forall assignment must be evaluated before the
4051 actual assignments are performed. Presumably this also applies to all the
4052 assignments in an inner where statement. */
4054 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4055 linear array, relying on the fact that we process in the same order in all
4058 forall (i=start:end:stride; maskexpr)
4062 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4064 count = ((end + 1 - start) / stride)
4065 masktmp(:) = maskexpr(:)
4068 for (i = start; i <= end; i += stride)
4070 if (masktmp[maskindex++])
4074 for (i = start; i <= end; i += stride)
4076 if (masktmp[maskindex++])
4080 Note that this code only works when there are no dependencies.
4081 Forall loop with array assignments and data dependencies are a real pain,
4082 because the size of the temporary cannot always be determined before the
4083 loop is executed. This problem is compounded by the presence of nested
4088 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4105 tree cycle_label
= NULL_TREE
;
4109 gfc_forall_iterator
*fa
;
4112 gfc_saved_var
*saved_vars
;
4113 iter_info
*this_forall
;
4117 /* Do nothing if the mask is false. */
4119 && code
->expr1
->expr_type
== EXPR_CONSTANT
4120 && !code
->expr1
->value
.logical
)
4121 return build_empty_stmt (input_location
);
4124 /* Count the FORALL index number. */
4125 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4129 /* Allocate the space for var, start, end, step, varexpr. */
4130 var
= XCNEWVEC (tree
, nvar
);
4131 start
= XCNEWVEC (tree
, nvar
);
4132 end
= XCNEWVEC (tree
, nvar
);
4133 step
= XCNEWVEC (tree
, nvar
);
4134 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4135 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4137 /* Allocate the space for info. */
4138 info
= XCNEW (forall_info
);
4140 gfc_start_block (&pre
);
4141 gfc_init_block (&post
);
4142 gfc_init_block (&block
);
4145 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4147 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4149 /* Allocate space for this_forall. */
4150 this_forall
= XCNEW (iter_info
);
4152 /* Create a temporary variable for the FORALL index. */
4153 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4154 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4155 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4157 /* Record it in this_forall. */
4158 this_forall
->var
= var
[n
];
4160 /* Replace the index symbol's backend_decl with the temporary decl. */
4161 sym
->backend_decl
= var
[n
];
4163 /* Work out the start, end and stride for the loop. */
4164 gfc_init_se (&se
, NULL
);
4165 gfc_conv_expr_val (&se
, fa
->start
);
4166 /* Record it in this_forall. */
4167 this_forall
->start
= se
.expr
;
4168 gfc_add_block_to_block (&block
, &se
.pre
);
4171 gfc_init_se (&se
, NULL
);
4172 gfc_conv_expr_val (&se
, fa
->end
);
4173 /* Record it in this_forall. */
4174 this_forall
->end
= se
.expr
;
4175 gfc_make_safe_expr (&se
);
4176 gfc_add_block_to_block (&block
, &se
.pre
);
4179 gfc_init_se (&se
, NULL
);
4180 gfc_conv_expr_val (&se
, fa
->stride
);
4181 /* Record it in this_forall. */
4182 this_forall
->step
= se
.expr
;
4183 gfc_make_safe_expr (&se
);
4184 gfc_add_block_to_block (&block
, &se
.pre
);
4187 /* Set the NEXT field of this_forall to NULL. */
4188 this_forall
->next
= NULL
;
4189 /* Link this_forall to the info construct. */
4190 if (info
->this_loop
)
4192 iter_info
*iter_tmp
= info
->this_loop
;
4193 while (iter_tmp
->next
!= NULL
)
4194 iter_tmp
= iter_tmp
->next
;
4195 iter_tmp
->next
= this_forall
;
4198 info
->this_loop
= this_forall
;
4204 /* Calculate the size needed for the current forall level. */
4205 size
= gfc_index_one_node
;
4206 for (n
= 0; n
< nvar
; n
++)
4208 /* size = (end + step - start) / step. */
4209 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4211 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4213 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4215 tmp
= convert (gfc_array_index_type
, tmp
);
4217 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4221 /* Record the nvar and size of current forall level. */
4227 /* If the mask is .true., consider the FORALL unconditional. */
4228 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4229 && code
->expr1
->value
.logical
)
4237 /* First we need to allocate the mask. */
4240 /* As the mask array can be very big, prefer compact boolean types. */
4241 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4242 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4243 size
, NULL
, &block
, &pmask
);
4244 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4246 /* Record them in the info structure. */
4247 info
->maskindex
= maskindex
;
4252 /* No mask was specified. */
4253 maskindex
= NULL_TREE
;
4254 mask
= pmask
= NULL_TREE
;
4257 /* Link the current forall level to nested_forall_info. */
4258 info
->prev_nest
= nested_forall_info
;
4259 nested_forall_info
= info
;
4261 /* Copy the mask into a temporary variable if required.
4262 For now we assume a mask temporary is needed. */
4265 /* As the mask array can be very big, prefer compact boolean types. */
4266 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4268 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4270 /* Start of mask assignment loop body. */
4271 gfc_start_block (&body
);
4273 /* Evaluate the mask expression. */
4274 gfc_init_se (&se
, NULL
);
4275 gfc_conv_expr_val (&se
, code
->expr1
);
4276 gfc_add_block_to_block (&body
, &se
.pre
);
4278 /* Store the mask. */
4279 se
.expr
= convert (mask_type
, se
.expr
);
4281 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4282 gfc_add_modify (&body
, tmp
, se
.expr
);
4284 /* Advance to the next mask element. */
4285 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4286 maskindex
, gfc_index_one_node
);
4287 gfc_add_modify (&body
, maskindex
, tmp
);
4289 /* Generate the loops. */
4290 tmp
= gfc_finish_block (&body
);
4291 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4292 gfc_add_expr_to_block (&block
, tmp
);
4295 if (code
->op
== EXEC_DO_CONCURRENT
)
4297 gfc_init_block (&body
);
4298 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4299 code
->cycle_label
= cycle_label
;
4300 tmp
= gfc_trans_code (code
->block
->next
);
4301 gfc_add_expr_to_block (&body
, tmp
);
4303 if (TREE_USED (cycle_label
))
4305 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4306 gfc_add_expr_to_block (&body
, tmp
);
4309 tmp
= gfc_finish_block (&body
);
4310 nested_forall_info
->do_concurrent
= true;
4311 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4312 gfc_add_expr_to_block (&block
, tmp
);
4316 c
= code
->block
->next
;
4318 /* TODO: loop merging in FORALL statements. */
4319 /* Now that we've got a copy of the mask, generate the assignment loops. */
4325 /* A scalar or array assignment. DO the simple check for
4326 lhs to rhs dependencies. These make a temporary for the
4327 rhs and form a second forall block to copy to variable. */
4328 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4330 /* Temporaries due to array assignment data dependencies introduce
4331 no end of problems. */
4333 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4334 nested_forall_info
, &block
);
4337 /* Use the normal assignment copying routines. */
4338 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4340 /* Generate body and loops. */
4341 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4343 gfc_add_expr_to_block (&block
, tmp
);
4346 /* Cleanup any temporary symtrees that have been made to deal
4347 with dependencies. */
4349 cleanup_forall_symtrees (c
);
4354 /* Translate WHERE or WHERE construct nested in FORALL. */
4355 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4358 /* Pointer assignment inside FORALL. */
4359 case EXEC_POINTER_ASSIGN
:
4360 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4362 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4363 nested_forall_info
, &block
);
4366 /* Use the normal assignment copying routines. */
4367 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4369 /* Generate body and loops. */
4370 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4372 gfc_add_expr_to_block (&block
, tmp
);
4377 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4378 gfc_add_expr_to_block (&block
, tmp
);
4381 /* Explicit subroutine calls are prevented by the frontend but interface
4382 assignments can legitimately produce them. */
4383 case EXEC_ASSIGN_CALL
:
4384 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4385 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4386 gfc_add_expr_to_block (&block
, tmp
);
4397 /* Restore the original index variables. */
4398 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4399 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4401 /* Free the space for var, start, end, step, varexpr. */
4409 for (this_forall
= info
->this_loop
; this_forall
;)
4411 iter_info
*next
= this_forall
->next
;
4416 /* Free the space for this forall_info. */
4421 /* Free the temporary for the mask. */
4422 tmp
= gfc_call_free (pmask
);
4423 gfc_add_expr_to_block (&block
, tmp
);
4426 pushdecl (maskindex
);
4428 gfc_add_block_to_block (&pre
, &block
);
4429 gfc_add_block_to_block (&pre
, &post
);
4431 return gfc_finish_block (&pre
);
4435 /* Translate the FORALL statement or construct. */
4437 tree
gfc_trans_forall (gfc_code
* code
)
4439 return gfc_trans_forall_1 (code
, NULL
);
4443 /* Translate the DO CONCURRENT construct. */
4445 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4447 return gfc_trans_forall_1 (code
, NULL
);
4451 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4452 If the WHERE construct is nested in FORALL, compute the overall temporary
4453 needed by the WHERE mask expression multiplied by the iterator number of
4455 ME is the WHERE mask expression.
4456 MASK is the current execution mask upon input, whose sense may or may
4457 not be inverted as specified by the INVERT argument.
4458 CMASK is the updated execution mask on output, or NULL if not required.
4459 PMASK is the pending execution mask on output, or NULL if not required.
4460 BLOCK is the block in which to place the condition evaluation loops. */
4463 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4464 tree mask
, bool invert
, tree cmask
, tree pmask
,
4465 tree mask_type
, stmtblock_t
* block
)
4470 stmtblock_t body
, body1
;
4471 tree count
, cond
, mtmp
;
4474 gfc_init_loopinfo (&loop
);
4476 lss
= gfc_walk_expr (me
);
4477 rss
= gfc_walk_expr (me
);
4479 /* Variable to index the temporary. */
4480 count
= gfc_create_var (gfc_array_index_type
, "count");
4481 /* Initialize count. */
4482 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4484 gfc_start_block (&body
);
4486 gfc_init_se (&rse
, NULL
);
4487 gfc_init_se (&lse
, NULL
);
4489 if (lss
== gfc_ss_terminator
)
4491 gfc_init_block (&body1
);
4495 /* Initialize the loop. */
4496 gfc_init_loopinfo (&loop
);
4498 /* We may need LSS to determine the shape of the expression. */
4499 gfc_add_ss_to_loop (&loop
, lss
);
4500 gfc_add_ss_to_loop (&loop
, rss
);
4502 gfc_conv_ss_startstride (&loop
);
4503 gfc_conv_loop_setup (&loop
, &me
->where
);
4505 gfc_mark_ss_chain_used (rss
, 1);
4506 /* Start the loop body. */
4507 gfc_start_scalarized_body (&loop
, &body1
);
4509 /* Translate the expression. */
4510 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4512 gfc_conv_expr (&rse
, me
);
4515 /* Variable to evaluate mask condition. */
4516 cond
= gfc_create_var (mask_type
, "cond");
4517 if (mask
&& (cmask
|| pmask
))
4518 mtmp
= gfc_create_var (mask_type
, "mask");
4519 else mtmp
= NULL_TREE
;
4521 gfc_add_block_to_block (&body1
, &lse
.pre
);
4522 gfc_add_block_to_block (&body1
, &rse
.pre
);
4524 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4526 if (mask
&& (cmask
|| pmask
))
4528 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4530 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4531 gfc_add_modify (&body1
, mtmp
, tmp
);
4536 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4539 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4541 gfc_add_modify (&body1
, tmp1
, tmp
);
4546 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4547 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4549 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4551 gfc_add_modify (&body1
, tmp1
, tmp
);
4554 gfc_add_block_to_block (&body1
, &lse
.post
);
4555 gfc_add_block_to_block (&body1
, &rse
.post
);
4557 if (lss
== gfc_ss_terminator
)
4559 gfc_add_block_to_block (&body
, &body1
);
4563 /* Increment count. */
4564 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4565 count
, gfc_index_one_node
);
4566 gfc_add_modify (&body1
, count
, tmp1
);
4568 /* Generate the copying loops. */
4569 gfc_trans_scalarizing_loops (&loop
, &body1
);
4571 gfc_add_block_to_block (&body
, &loop
.pre
);
4572 gfc_add_block_to_block (&body
, &loop
.post
);
4574 gfc_cleanup_loop (&loop
);
4575 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4576 as tree nodes in SS may not be valid in different scope. */
4579 tmp1
= gfc_finish_block (&body
);
4580 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4581 if (nested_forall_info
!= NULL
)
4582 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4584 gfc_add_expr_to_block (block
, tmp1
);
4588 /* Translate an assignment statement in a WHERE statement or construct
4589 statement. The MASK expression is used to control which elements
4590 of EXPR1 shall be assigned. The sense of MASK is specified by
4594 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4595 tree mask
, bool invert
,
4596 tree count1
, tree count2
,
4602 gfc_ss
*lss_section
;
4609 tree index
, maskexpr
;
4611 /* A defined assignment. */
4612 if (cnext
&& cnext
->resolved_sym
)
4613 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4616 /* TODO: handle this special case.
4617 Special case a single function returning an array. */
4618 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4620 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4626 /* Assignment of the form lhs = rhs. */
4627 gfc_start_block (&block
);
4629 gfc_init_se (&lse
, NULL
);
4630 gfc_init_se (&rse
, NULL
);
4633 lss
= gfc_walk_expr (expr1
);
4636 /* In each where-assign-stmt, the mask-expr and the variable being
4637 defined shall be arrays of the same shape. */
4638 gcc_assert (lss
!= gfc_ss_terminator
);
4640 /* The assignment needs scalarization. */
4643 /* Find a non-scalar SS from the lhs. */
4644 while (lss_section
!= gfc_ss_terminator
4645 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4646 lss_section
= lss_section
->next
;
4648 gcc_assert (lss_section
!= gfc_ss_terminator
);
4650 /* Initialize the scalarizer. */
4651 gfc_init_loopinfo (&loop
);
4654 rss
= gfc_walk_expr (expr2
);
4655 if (rss
== gfc_ss_terminator
)
4657 /* The rhs is scalar. Add a ss for the expression. */
4658 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4659 rss
->info
->where
= 1;
4662 /* Associate the SS with the loop. */
4663 gfc_add_ss_to_loop (&loop
, lss
);
4664 gfc_add_ss_to_loop (&loop
, rss
);
4666 /* Calculate the bounds of the scalarization. */
4667 gfc_conv_ss_startstride (&loop
);
4669 /* Resolve any data dependencies in the statement. */
4670 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4672 /* Setup the scalarizing loops. */
4673 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4675 /* Setup the gfc_se structures. */
4676 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4677 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4680 gfc_mark_ss_chain_used (rss
, 1);
4681 if (loop
.temp_ss
== NULL
)
4684 gfc_mark_ss_chain_used (lss
, 1);
4688 lse
.ss
= loop
.temp_ss
;
4689 gfc_mark_ss_chain_used (lss
, 3);
4690 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4693 /* Start the scalarized loop body. */
4694 gfc_start_scalarized_body (&loop
, &body
);
4696 /* Translate the expression. */
4697 gfc_conv_expr (&rse
, expr2
);
4698 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4699 gfc_conv_tmp_array_ref (&lse
);
4701 gfc_conv_expr (&lse
, expr1
);
4703 /* Form the mask expression according to the mask. */
4705 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4707 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4708 TREE_TYPE (maskexpr
), maskexpr
);
4710 /* Use the scalar assignment as is. */
4711 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4712 false, loop
.temp_ss
== NULL
);
4714 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4716 gfc_add_expr_to_block (&body
, tmp
);
4718 if (lss
== gfc_ss_terminator
)
4720 /* Increment count1. */
4721 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4722 count1
, gfc_index_one_node
);
4723 gfc_add_modify (&body
, count1
, tmp
);
4725 /* Use the scalar assignment as is. */
4726 gfc_add_block_to_block (&block
, &body
);
4730 gcc_assert (lse
.ss
== gfc_ss_terminator
4731 && rse
.ss
== gfc_ss_terminator
);
4733 if (loop
.temp_ss
!= NULL
)
4735 /* Increment count1 before finish the main body of a scalarized
4737 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4738 gfc_array_index_type
, count1
, gfc_index_one_node
);
4739 gfc_add_modify (&body
, count1
, tmp
);
4740 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4742 /* We need to copy the temporary to the actual lhs. */
4743 gfc_init_se (&lse
, NULL
);
4744 gfc_init_se (&rse
, NULL
);
4745 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4746 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4748 rse
.ss
= loop
.temp_ss
;
4751 gfc_conv_tmp_array_ref (&rse
);
4752 gfc_conv_expr (&lse
, expr1
);
4754 gcc_assert (lse
.ss
== gfc_ss_terminator
4755 && rse
.ss
== gfc_ss_terminator
);
4757 /* Form the mask expression according to the mask tree list. */
4759 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4761 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4762 TREE_TYPE (maskexpr
), maskexpr
);
4764 /* Use the scalar assignment as is. */
4765 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
4766 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
4767 build_empty_stmt (input_location
));
4768 gfc_add_expr_to_block (&body
, tmp
);
4770 /* Increment count2. */
4771 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4772 gfc_array_index_type
, count2
,
4773 gfc_index_one_node
);
4774 gfc_add_modify (&body
, count2
, tmp
);
4778 /* Increment count1. */
4779 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4780 gfc_array_index_type
, count1
,
4781 gfc_index_one_node
);
4782 gfc_add_modify (&body
, count1
, tmp
);
4785 /* Generate the copying loops. */
4786 gfc_trans_scalarizing_loops (&loop
, &body
);
4788 /* Wrap the whole thing up. */
4789 gfc_add_block_to_block (&block
, &loop
.pre
);
4790 gfc_add_block_to_block (&block
, &loop
.post
);
4791 gfc_cleanup_loop (&loop
);
4794 return gfc_finish_block (&block
);
4798 /* Translate the WHERE construct or statement.
4799 This function can be called iteratively to translate the nested WHERE
4800 construct or statement.
4801 MASK is the control mask. */
4804 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
4805 forall_info
* nested_forall_info
, stmtblock_t
* block
)
4807 stmtblock_t inner_size_body
;
4808 tree inner_size
, size
;
4817 tree count1
, count2
;
4821 tree pcmask
= NULL_TREE
;
4822 tree ppmask
= NULL_TREE
;
4823 tree cmask
= NULL_TREE
;
4824 tree pmask
= NULL_TREE
;
4825 gfc_actual_arglist
*arg
;
4827 /* the WHERE statement or the WHERE construct statement. */
4828 cblock
= code
->block
;
4830 /* As the mask array can be very big, prefer compact boolean types. */
4831 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4833 /* Determine which temporary masks are needed. */
4836 /* One clause: No ELSEWHEREs. */
4837 need_cmask
= (cblock
->next
!= 0);
4840 else if (cblock
->block
->block
)
4842 /* Three or more clauses: Conditional ELSEWHEREs. */
4846 else if (cblock
->next
)
4848 /* Two clauses, the first non-empty. */
4850 need_pmask
= (mask
!= NULL_TREE
4851 && cblock
->block
->next
!= 0);
4853 else if (!cblock
->block
->next
)
4855 /* Two clauses, both empty. */
4859 /* Two clauses, the first empty, the second non-empty. */
4862 need_cmask
= (cblock
->block
->expr1
!= 0);
4871 if (need_cmask
|| need_pmask
)
4873 /* Calculate the size of temporary needed by the mask-expr. */
4874 gfc_init_block (&inner_size_body
);
4875 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
4876 &inner_size_body
, &lss
, &rss
);
4878 gfc_free_ss_chain (lss
);
4879 gfc_free_ss_chain (rss
);
4881 /* Calculate the total size of temporary needed. */
4882 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4883 &inner_size_body
, block
);
4885 /* Check whether the size is negative. */
4886 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
4887 gfc_index_zero_node
);
4888 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
4889 cond
, gfc_index_zero_node
, size
);
4890 size
= gfc_evaluate_now (size
, block
);
4892 /* Allocate temporary for WHERE mask if needed. */
4894 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4897 /* Allocate temporary for !mask if needed. */
4899 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4905 /* Each time around this loop, the where clause is conditional
4906 on the value of mask and invert, which are updated at the
4907 bottom of the loop. */
4909 /* Has mask-expr. */
4912 /* Ensure that the WHERE mask will be evaluated exactly once.
4913 If there are no statements in this WHERE/ELSEWHERE clause,
4914 then we don't need to update the control mask (cmask).
4915 If this is the last clause of the WHERE construct, then
4916 we don't need to update the pending control mask (pmask). */
4918 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4920 cblock
->next
? cmask
: NULL_TREE
,
4921 cblock
->block
? pmask
: NULL_TREE
,
4924 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4926 (cblock
->next
|| cblock
->block
)
4927 ? cmask
: NULL_TREE
,
4928 NULL_TREE
, mask_type
, block
);
4932 /* It's a final elsewhere-stmt. No mask-expr is present. */
4936 /* The body of this where clause are controlled by cmask with
4937 sense specified by invert. */
4939 /* Get the assignment statement of a WHERE statement, or the first
4940 statement in where-body-construct of a WHERE construct. */
4941 cnext
= cblock
->next
;
4946 /* WHERE assignment statement. */
4947 case EXEC_ASSIGN_CALL
:
4949 arg
= cnext
->ext
.actual
;
4950 expr1
= expr2
= NULL
;
4951 for (; arg
; arg
= arg
->next
)
4963 expr1
= cnext
->expr1
;
4964 expr2
= cnext
->expr2
;
4966 if (nested_forall_info
!= NULL
)
4968 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
4969 if (need_temp
&& cnext
->op
!= EXEC_ASSIGN_CALL
)
4970 gfc_trans_assign_need_temp (expr1
, expr2
,
4972 nested_forall_info
, block
);
4975 /* Variables to control maskexpr. */
4976 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4977 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4978 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4979 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4981 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4986 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4988 gfc_add_expr_to_block (block
, tmp
);
4993 /* Variables to control maskexpr. */
4994 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4995 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4996 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4997 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4999 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5003 gfc_add_expr_to_block (block
, tmp
);
5008 /* WHERE or WHERE construct is part of a where-body-construct. */
5010 gfc_trans_where_2 (cnext
, cmask
, invert
,
5011 nested_forall_info
, block
);
5018 /* The next statement within the same where-body-construct. */
5019 cnext
= cnext
->next
;
5021 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5022 cblock
= cblock
->block
;
5023 if (mask
== NULL_TREE
)
5025 /* If we're the initial WHERE, we can simply invert the sense
5026 of the current mask to obtain the "mask" for the remaining
5033 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5039 /* If we allocated a pending mask array, deallocate it now. */
5042 tmp
= gfc_call_free (ppmask
);
5043 gfc_add_expr_to_block (block
, tmp
);
5046 /* If we allocated a current mask array, deallocate it now. */
5049 tmp
= gfc_call_free (pcmask
);
5050 gfc_add_expr_to_block (block
, tmp
);
5054 /* Translate a simple WHERE construct or statement without dependencies.
5055 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5056 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5057 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5060 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5062 stmtblock_t block
, body
;
5063 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5064 tree tmp
, cexpr
, tstmt
, estmt
;
5065 gfc_ss
*css
, *tdss
, *tsss
;
5066 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5070 bool maybe_workshare
= false;
5072 /* Allow the scalarizer to workshare simple where loops. */
5073 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5074 == OMPWS_WORKSHARE_FLAG
)
5076 maybe_workshare
= true;
5077 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5080 cond
= cblock
->expr1
;
5081 tdst
= cblock
->next
->expr1
;
5082 tsrc
= cblock
->next
->expr2
;
5083 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5084 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5086 gfc_start_block (&block
);
5087 gfc_init_loopinfo (&loop
);
5089 /* Handle the condition. */
5090 gfc_init_se (&cse
, NULL
);
5091 css
= gfc_walk_expr (cond
);
5092 gfc_add_ss_to_loop (&loop
, css
);
5094 /* Handle the then-clause. */
5095 gfc_init_se (&tdse
, NULL
);
5096 gfc_init_se (&tsse
, NULL
);
5097 tdss
= gfc_walk_expr (tdst
);
5098 tsss
= gfc_walk_expr (tsrc
);
5099 if (tsss
== gfc_ss_terminator
)
5101 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5102 tsss
->info
->where
= 1;
5104 gfc_add_ss_to_loop (&loop
, tdss
);
5105 gfc_add_ss_to_loop (&loop
, tsss
);
5109 /* Handle the else clause. */
5110 gfc_init_se (&edse
, NULL
);
5111 gfc_init_se (&esse
, NULL
);
5112 edss
= gfc_walk_expr (edst
);
5113 esss
= gfc_walk_expr (esrc
);
5114 if (esss
== gfc_ss_terminator
)
5116 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5117 esss
->info
->where
= 1;
5119 gfc_add_ss_to_loop (&loop
, edss
);
5120 gfc_add_ss_to_loop (&loop
, esss
);
5123 gfc_conv_ss_startstride (&loop
);
5124 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5126 gfc_mark_ss_chain_used (css
, 1);
5127 gfc_mark_ss_chain_used (tdss
, 1);
5128 gfc_mark_ss_chain_used (tsss
, 1);
5131 gfc_mark_ss_chain_used (edss
, 1);
5132 gfc_mark_ss_chain_used (esss
, 1);
5135 gfc_start_scalarized_body (&loop
, &body
);
5137 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5138 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5139 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5145 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5146 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5151 gfc_conv_expr (&cse
, cond
);
5152 gfc_add_block_to_block (&body
, &cse
.pre
);
5155 gfc_conv_expr (&tsse
, tsrc
);
5156 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5157 gfc_conv_tmp_array_ref (&tdse
);
5159 gfc_conv_expr (&tdse
, tdst
);
5163 gfc_conv_expr (&esse
, esrc
);
5164 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5165 gfc_conv_tmp_array_ref (&edse
);
5167 gfc_conv_expr (&edse
, edst
);
5170 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5171 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5173 : build_empty_stmt (input_location
);
5174 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5175 gfc_add_expr_to_block (&body
, tmp
);
5176 gfc_add_block_to_block (&body
, &cse
.post
);
5178 if (maybe_workshare
)
5179 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5180 gfc_trans_scalarizing_loops (&loop
, &body
);
5181 gfc_add_block_to_block (&block
, &loop
.pre
);
5182 gfc_add_block_to_block (&block
, &loop
.post
);
5183 gfc_cleanup_loop (&loop
);
5185 return gfc_finish_block (&block
);
5188 /* As the WHERE or WHERE construct statement can be nested, we call
5189 gfc_trans_where_2 to do the translation, and pass the initial
5190 NULL values for both the control mask and the pending control mask. */
5193 gfc_trans_where (gfc_code
* code
)
5199 cblock
= code
->block
;
5201 && cblock
->next
->op
== EXEC_ASSIGN
5202 && !cblock
->next
->next
)
5204 eblock
= cblock
->block
;
5207 /* A simple "WHERE (cond) x = y" statement or block is
5208 dependence free if cond is not dependent upon writing x,
5209 and the source y is unaffected by the destination x. */
5210 if (!gfc_check_dependency (cblock
->next
->expr1
,
5212 && !gfc_check_dependency (cblock
->next
->expr1
,
5213 cblock
->next
->expr2
, 0))
5214 return gfc_trans_where_3 (cblock
, NULL
);
5216 else if (!eblock
->expr1
5219 && eblock
->next
->op
== EXEC_ASSIGN
5220 && !eblock
->next
->next
)
5222 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5223 block is dependence free if cond is not dependent on writes
5224 to x1 and x2, y1 is not dependent on writes to x2, and y2
5225 is not dependent on writes to x1, and both y's are not
5226 dependent upon their own x's. In addition to this, the
5227 final two dependency checks below exclude all but the same
5228 array reference if the where and elswhere destinations
5229 are the same. In short, this is VERY conservative and this
5230 is needed because the two loops, required by the standard
5231 are coalesced in gfc_trans_where_3. */
5232 if (!gfc_check_dependency (cblock
->next
->expr1
,
5234 && !gfc_check_dependency (eblock
->next
->expr1
,
5236 && !gfc_check_dependency (cblock
->next
->expr1
,
5237 eblock
->next
->expr2
, 1)
5238 && !gfc_check_dependency (eblock
->next
->expr1
,
5239 cblock
->next
->expr2
, 1)
5240 && !gfc_check_dependency (cblock
->next
->expr1
,
5241 cblock
->next
->expr2
, 1)
5242 && !gfc_check_dependency (eblock
->next
->expr1
,
5243 eblock
->next
->expr2
, 1)
5244 && !gfc_check_dependency (cblock
->next
->expr1
,
5245 eblock
->next
->expr1
, 0)
5246 && !gfc_check_dependency (eblock
->next
->expr1
,
5247 cblock
->next
->expr1
, 0))
5248 return gfc_trans_where_3 (cblock
, eblock
);
5252 gfc_start_block (&block
);
5254 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5256 return gfc_finish_block (&block
);
5260 /* CYCLE a DO loop. The label decl has already been created by
5261 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5262 node at the head of the loop. We must mark the label as used. */
5265 gfc_trans_cycle (gfc_code
* code
)
5269 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5270 gcc_assert (cycle_label
);
5272 TREE_USED (cycle_label
) = 1;
5273 return build1_v (GOTO_EXPR
, cycle_label
);
5277 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5278 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5282 gfc_trans_exit (gfc_code
* code
)
5286 exit_label
= code
->ext
.which_construct
->exit_label
;
5287 gcc_assert (exit_label
);
5289 TREE_USED (exit_label
) = 1;
5290 return build1_v (GOTO_EXPR
, exit_label
);
5294 /* Translate the ALLOCATE statement. */
5297 gfc_trans_allocate (gfc_code
* code
)
5300 gfc_expr
*expr
, *e3rhs
= NULL
;
5310 tree al_vptr
, al_len
;
5311 /* If an expr3 is present, then store the tree for accessing its
5312 _vptr, and _len components in the variables, respectively. The
5313 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5314 the trees may be the NULL_TREE indicating that this is not
5315 available for expr3's type. */
5316 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5317 /* Classify what expr3 stores. */
5318 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5322 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
;
5323 gfc_symtree
*newsym
= NULL
;
5325 if (!code
->ext
.alloc
.list
)
5328 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5329 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5330 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5333 gfc_init_block (&block
);
5334 gfc_init_block (&post
);
5336 /* STAT= (and maybe ERRMSG=) is present. */
5340 tree gfc_int4_type_node
= gfc_get_int_type (4);
5341 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5343 /* ERRMSG= only makes sense with STAT=. */
5346 gfc_init_se (&se
, NULL
);
5347 se
.want_pointer
= 1;
5348 gfc_conv_expr_lhs (&se
, code
->expr2
);
5350 errlen
= se
.string_length
;
5354 errmsg
= null_pointer_node
;
5355 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5358 /* GOTO destinations. */
5359 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5360 label_finish
= gfc_build_label_decl (NULL_TREE
);
5361 TREE_USED (label_finish
) = 0;
5364 /* When an expr3 is present evaluate it only once. The standards prevent a
5365 dependency of expr3 on the objects in the allocate list. An expr3 can
5366 be pre-evaluated in all cases. One just has to make sure, to use the
5367 correct way, i.e., to get the descriptor or to get a reference
5371 bool vtab_needed
= false, temp_var_needed
= false,
5372 is_coarray
= gfc_is_coarray (code
->expr3
);
5374 /* Figure whether we need the vtab from expr3. */
5375 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5377 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5379 gfc_init_se (&se
, NULL
);
5380 /* When expr3 is a variable, i.e., a very simple expression,
5381 then convert it once here. */
5382 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5383 || code
->expr3
->expr_type
== EXPR_ARRAY
5384 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5386 if (!code
->expr3
->mold
5387 || code
->expr3
->ts
.type
== BT_CHARACTER
5389 || code
->ext
.alloc
.arr_spec_from_expr3
)
5391 /* Convert expr3 to a tree. For all "simple" expression just
5392 get the descriptor or the reference, respectively, depending
5393 on the rank of the expr. */
5394 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5395 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5398 gfc_conv_expr_reference (&se
, code
->expr3
);
5400 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5401 NOP_EXPR, which prevents gfortran from getting the vptr
5402 from the source=-expression. Remove the NOP_EXPR and go
5403 with the POINTER_PLUS_EXPR in this case. */
5404 if (code
->expr3
->ts
.type
== BT_CLASS
5405 && TREE_CODE (se
.expr
) == NOP_EXPR
5406 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5407 == POINTER_PLUS_EXPR
5409 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5411 /* Create a temp variable only for component refs to prevent
5412 having to go through the full deref-chain each time and to
5413 simplfy computation of array properties. */
5414 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5419 /* In all other cases evaluate the expr3. */
5420 symbol_attribute attr
;
5421 /* Get the descriptor for all arrays, that are not allocatable or
5422 pointer, because the latter are descriptors already.
5423 The exception are function calls returning a class object:
5424 The descriptor is stored in their results _data component, which
5425 is easier to access, when first a temporary variable for the
5426 result is created and the descriptor retrieved from there. */
5427 attr
= gfc_expr_attr (code
->expr3
);
5428 if (code
->expr3
->rank
!= 0
5429 && ((!attr
.allocatable
&& !attr
.pointer
)
5430 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5431 && code
->expr3
->ts
.type
!= BT_CLASS
)))
5432 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5434 gfc_conv_expr_reference (&se
, code
->expr3
);
5435 if (code
->expr3
->ts
.type
== BT_CLASS
)
5436 gfc_conv_class_to_class (&se
, code
->expr3
,
5440 temp_var_needed
= !VAR_P (se
.expr
);
5442 gfc_add_block_to_block (&block
, &se
.pre
);
5443 gfc_add_block_to_block (&post
, &se
.post
);
5444 /* Prevent aliasing, i.e., se.expr may be already a
5445 variable declaration. */
5446 if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5449 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5451 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5453 /* Get the array descriptor and prepare it to be assigned to the
5454 temporary variable var. For classes the array descriptor is
5455 in the _data component and the object goes into the
5456 GFC_DECL_SAVED_DESCRIPTOR. */
5457 if (code
->expr3
->ts
.type
== BT_CLASS
5458 && code
->expr3
->rank
!= 0)
5460 /* When an array_ref was in expr3, then the descriptor is the
5462 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5464 desc
= TREE_OPERAND (tmp
, 0);
5469 tmp
= gfc_class_data_get (tmp
);
5474 desc
= !is_coarray
? se
.expr
5475 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5476 /* We need a regular (non-UID) symbol here, therefore give a
5478 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5479 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5481 gfc_allocate_lang_decl (var
);
5482 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5484 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5486 /* Deallocate any allocatable components after all the allocations
5487 and assignments of expr3 have been completed. */
5488 if (code
->expr3
->ts
.type
== BT_DERIVED
5489 && code
->expr3
->rank
== 0
5490 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
)
5492 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
5494 gfc_add_expr_to_block (&post
, tmp
);
5498 if (se
.string_length
)
5499 /* Evaluate it assuming that it also is complicated like expr3. */
5500 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5505 expr3_len
= se
.string_length
;
5507 /* Store what the expr3 is to be used for. */
5508 if (e3_is
== E3_UNSET
)
5509 e3_is
= expr3
!= NULL_TREE
?
5510 (code
->ext
.alloc
.arr_spec_from_expr3
?
5512 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
5515 /* Figure how to get the _vtab entry. This also obtains the tree
5516 expression for accessing the _len component, because only
5517 unlimited polymorphic objects, which are a subcategory of class
5518 types, have a _len component. */
5519 if (code
->expr3
->ts
.type
== BT_CLASS
)
5522 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
5523 build_fold_indirect_ref (expr3
): expr3
;
5524 /* Polymorphic SOURCE: VPTR must be determined at run time.
5525 expr3 may be a temporary array declaration, therefore check for
5526 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5527 if (tmp
!= NULL_TREE
5528 && (e3_is
== E3_DESC
5529 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
5530 && (VAR_P (tmp
) || !code
->expr3
->ref
))
5531 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
5532 tmp
= gfc_class_vptr_get (expr3
);
5535 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5536 gfc_add_vptr_component (rhs
);
5537 gfc_init_se (&se
, NULL
);
5538 se
.want_pointer
= 1;
5539 gfc_conv_expr (&se
, rhs
);
5541 gfc_free_expr (rhs
);
5543 /* Set the element size. */
5544 expr3_esize
= gfc_vptr_size_get (tmp
);
5547 /* Initialize the ref to the _len component. */
5548 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5550 /* Same like for retrieving the _vptr. */
5551 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5552 expr3_len
= gfc_class_len_get (expr3
);
5555 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5556 gfc_add_len_component (rhs
);
5557 gfc_init_se (&se
, NULL
);
5558 gfc_conv_expr (&se
, rhs
);
5559 expr3_len
= se
.expr
;
5560 gfc_free_expr (rhs
);
5566 /* When the object to allocate is polymorphic type, then it
5567 needs its vtab set correctly, so deduce the required _vtab
5568 and _len from the source expression. */
5571 /* VPTR is fixed at compile time. */
5574 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5576 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5577 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5580 /* _len component needs to be set, when ts is a character
5582 if (expr3_len
== NULL_TREE
5583 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5585 if (code
->expr3
->ts
.u
.cl
5586 && code
->expr3
->ts
.u
.cl
->length
)
5588 gfc_init_se (&se
, NULL
);
5589 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5590 gfc_add_block_to_block (&block
, &se
.pre
);
5591 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5593 gcc_assert (expr3_len
);
5595 /* For character arrays only the kind's size is needed, because
5596 the array mem_size is _len * (elem_size = kind_size).
5597 For all other get the element size in the normal way. */
5598 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5599 expr3_esize
= TYPE_SIZE_UNIT (
5600 gfc_get_char_type (code
->expr3
->ts
.kind
));
5602 expr3_esize
= TYPE_SIZE_UNIT (
5603 gfc_typenode_for_spec (&code
->expr3
->ts
));
5605 /* The routine gfc_trans_assignment () already implements all
5606 techniques needed. Unfortunately we may have a temporary
5607 variable for the source= expression here. When that is the
5608 case convert this variable into a temporary gfc_expr of type
5609 EXPR_VARIABLE and used it as rhs for the assignment. The
5610 advantage is, that we get scalarizer support for free,
5611 don't have to take care about scalar to array treatment and
5612 will benefit of every enhancements gfc_trans_assignment ()
5614 No need to check whether e3_is is E3_UNSET, because that is
5615 done by expr3 != NULL_TREE.
5616 Exclude variables since the following block does not handle
5617 array sections. In any case, there is no harm in sending
5618 variables to gfc_trans_assignment because there is no
5619 evaluation of variables. */
5620 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
5621 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
5622 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5624 /* Build a temporary symtree and symbol. Do not add it to
5625 the current namespace to prevent accidently modifying
5626 a colliding symbol's as. */
5627 newsym
= XCNEW (gfc_symtree
);
5628 /* The name of the symtree should be unique, because
5629 gfc_create_var () took care about generating the
5631 newsym
->name
= gfc_get_string (IDENTIFIER_POINTER (
5632 DECL_NAME (expr3
)));
5633 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5634 /* The backend_decl is known. It is expr3, which is inserted
5636 newsym
->n
.sym
->backend_decl
= expr3
;
5637 e3rhs
= gfc_get_expr ();
5638 e3rhs
->ts
= code
->expr3
->ts
;
5639 e3rhs
->rank
= code
->expr3
->rank
;
5640 e3rhs
->symtree
= newsym
;
5641 /* Mark the symbol referenced or gfc_trans_assignment will
5643 newsym
->n
.sym
->attr
.referenced
= 1;
5644 e3rhs
->expr_type
= EXPR_VARIABLE
;
5645 e3rhs
->where
= code
->expr3
->where
;
5646 /* Set the symbols type, upto it was BT_UNKNOWN. */
5647 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5648 /* Check whether the expr3 is array valued. */
5651 gfc_array_spec
*arr
;
5652 arr
= gfc_get_array_spec ();
5653 arr
->rank
= e3rhs
->rank
;
5654 arr
->type
= AS_DEFERRED
;
5655 /* Set the dimension and pointer attribute for arrays
5656 to be on the safe side. */
5657 newsym
->n
.sym
->attr
.dimension
= 1;
5658 newsym
->n
.sym
->attr
.pointer
= 1;
5659 newsym
->n
.sym
->as
= arr
;
5660 gfc_add_full_array_ref (e3rhs
, arr
);
5662 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
5663 newsym
->n
.sym
->attr
.pointer
= 1;
5664 /* The string length is known to. Set it for char arrays. */
5665 if (e3rhs
->ts
.type
== BT_CHARACTER
)
5666 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
5667 gfc_commit_symbol (newsym
->n
.sym
);
5670 e3rhs
= gfc_copy_expr (code
->expr3
);
5672 gcc_assert (expr3_esize
);
5673 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5674 if (e3_is
== E3_MOLD
)
5676 /* The expr3 is no longer valid after this point. */
5681 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5683 /* Compute the explicit typespec given only once for all objects
5685 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5686 expr3_esize
= TYPE_SIZE_UNIT (
5687 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5691 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
);
5692 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5693 gfc_init_se (&se_sz
, NULL
);
5694 gfc_conv_expr (&se_sz
, sz
);
5696 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5697 tmp
= TYPE_SIZE_UNIT (tmp
);
5698 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5699 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5700 TREE_TYPE (se_sz
.expr
),
5705 /* Loop over all objects to allocate. */
5706 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5708 expr
= gfc_copy_expr (al
->expr
);
5709 /* UNLIMITED_POLY () needs the _data component to be set, when
5710 expr is a unlimited polymorphic object. But the _data component
5711 has not been set yet, so check the derived type's attr for the
5712 unlimited polymorphic flag to be safe. */
5713 upoly_expr
= UNLIMITED_POLY (expr
)
5714 || (expr
->ts
.type
== BT_DERIVED
5715 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
5716 gfc_init_se (&se
, NULL
);
5718 /* For class types prepare the expressions to ref the _vptr
5719 and the _len component. The latter for unlimited polymorphic
5721 if (expr
->ts
.type
== BT_CLASS
)
5723 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
5724 gfc_add_data_component (expr
);
5725 /* Prep the vptr handle. */
5726 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
5727 gfc_add_vptr_component (expr_ref_vptr
);
5728 se
.want_pointer
= 1;
5729 gfc_conv_expr (&se
, expr_ref_vptr
);
5731 se
.want_pointer
= 0;
5732 gfc_free_expr (expr_ref_vptr
);
5733 /* Allocated unlimited polymorphic objects always have a _len
5737 expr_ref_len
= gfc_copy_expr (al
->expr
);
5738 gfc_add_len_component (expr_ref_len
);
5739 gfc_conv_expr (&se
, expr_ref_len
);
5741 gfc_free_expr (expr_ref_len
);
5744 /* In a loop ensure that all loop variable dependent variables
5745 are initialized at the same spot in all execution paths. */
5749 al_vptr
= al_len
= NULL_TREE
;
5751 se
.want_pointer
= 1;
5752 se
.descriptor_only
= 1;
5754 gfc_conv_expr (&se
, expr
);
5755 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5756 /* se.string_length now stores the .string_length variable of expr
5757 needed to allocate character(len=:) arrays. */
5758 al_len
= se
.string_length
;
5760 al_len_needs_set
= al_len
!= NULL_TREE
;
5761 /* When allocating an array one can not use much of the
5762 pre-evaluated expr3 expressions, because for most of them the
5763 scalarizer is needed which is not available in the pre-evaluation
5764 step. Therefore gfc_array_allocate () is responsible (and able)
5765 to handle the complete array allocation. Only the element size
5766 needs to be provided, which is done most of the time by the
5767 pre-evaluation step. */
5769 if (expr3_len
&& code
->expr3
->ts
.type
== BT_CHARACTER
)
5770 /* When al is an array, then the element size for each element
5771 in the array is needed, which is the product of the len and
5772 esize for char arrays. */
5773 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5774 TREE_TYPE (expr3_esize
), expr3_esize
,
5775 fold_convert (TREE_TYPE (expr3_esize
),
5779 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
5780 label_finish
, tmp
, &nelems
,
5781 e3rhs
? e3rhs
: code
->expr3
,
5782 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
5783 code
->expr3
!= NULL
&& e3_is
== E3_DESC
5784 && code
->expr3
->expr_type
== EXPR_ARRAY
))
5786 /* A scalar or derived type. First compute the size to
5789 expr3_len is set when expr3 is an unlimited polymorphic
5790 object or a deferred length string. */
5791 if (expr3_len
!= NULL_TREE
)
5793 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
5794 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5795 TREE_TYPE (expr3_esize
),
5797 if (code
->expr3
->ts
.type
!= BT_CLASS
)
5798 /* expr3 is a deferred length string, i.e., we are
5803 /* For unlimited polymorphic enties build
5804 (len > 0) ? element_size * len : element_size
5805 to compute the number of bytes to allocate.
5806 This allows the allocation of unlimited polymorphic
5807 objects from an expr3 that is also unlimited
5808 polymorphic and stores a _len dependent object,
5810 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
5811 boolean_type_node
, expr3_len
,
5813 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
5814 TREE_TYPE (expr3_esize
),
5815 memsz
, tmp
, expr3_esize
);
5818 else if (expr3_esize
!= NULL_TREE
)
5819 /* Any other object in expr3 just needs element size in
5821 memsz
= expr3_esize
;
5822 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5824 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
5826 /* Allocating deferred length char arrays need the length
5827 to allocate in the alloc_type_spec. But also unlimited
5828 polymorphic objects may be allocated as char arrays.
5829 Both are handled here. */
5830 gfc_init_se (&se_sz
, NULL
);
5831 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5832 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5833 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
5834 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
5835 expr3_len
= se_sz
.expr
;
5836 tmp_expr3_len_flag
= true;
5837 tmp
= TYPE_SIZE_UNIT (
5838 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
5839 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5841 fold_convert (TREE_TYPE (tmp
),
5845 else if (expr
->ts
.type
== BT_CHARACTER
)
5847 /* Compute the number of bytes needed to allocate a fixed
5848 length char array. */
5849 gcc_assert (se
.string_length
!= NULL_TREE
);
5850 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
5851 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5852 TREE_TYPE (tmp
), tmp
,
5853 fold_convert (TREE_TYPE (tmp
),
5856 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5857 /* Handle all types, where the alloc_type_spec is set. */
5858 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5860 /* Handle size computation of the type declared to alloc. */
5861 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
5863 /* Allocate - for non-pointers with re-alloc checking. */
5864 if (gfc_expr_attr (expr
).allocatable
)
5865 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
, NULL_TREE
,
5866 stat
, errmsg
, errlen
, label_finish
,
5869 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
5871 if (al
->expr
->ts
.type
== BT_DERIVED
5872 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5874 tmp
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5875 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, tmp
, 0);
5876 gfc_add_expr_to_block (&se
.pre
, tmp
);
5881 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
5882 && expr3_len
!= NULL_TREE
)
5884 /* Arrays need to have a _len set before the array
5885 descriptor is filled. */
5886 gfc_add_modify (&block
, al_len
,
5887 fold_convert (TREE_TYPE (al_len
), expr3_len
));
5888 /* Prevent setting the length twice. */
5889 al_len_needs_set
= false;
5891 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
5892 && code
->ext
.alloc
.ts
.u
.cl
->length
)
5894 /* Cover the cases where a string length is explicitly
5895 specified by a type spec for deferred length character
5896 arrays or unlimited polymorphic objects without a
5897 source= or mold= expression. */
5898 gfc_init_se (&se_sz
, NULL
);
5899 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5900 gfc_add_modify (&block
, al_len
,
5901 fold_convert (TREE_TYPE (al_len
),
5903 al_len_needs_set
= false;
5907 gfc_add_block_to_block (&block
, &se
.pre
);
5909 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
5912 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
5913 parm
= fold_build2_loc (input_location
, NE_EXPR
,
5914 boolean_type_node
, stat
,
5915 build_int_cst (TREE_TYPE (stat
), 0));
5916 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5917 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
5918 tmp
, build_empty_stmt (input_location
));
5919 gfc_add_expr_to_block (&block
, tmp
);
5923 if (al_vptr
!= NULL_TREE
)
5925 if (expr3_vptr
!= NULL_TREE
)
5926 /* The vtab is already known, so just assign it. */
5927 gfc_add_modify (&block
, al_vptr
,
5928 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
5931 /* VPTR is fixed at compile time. */
5936 /* Although expr3 is pre-evaluated above, it may happen,
5937 that for arrays or in mold= cases the pre-evaluation
5938 was not successful. In these rare cases take the vtab
5939 from the typespec of expr3 here. */
5940 ts
= &code
->expr3
->ts
;
5941 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
5942 /* The alloc_type_spec gives the type to allocate or the
5943 al is unlimited polymorphic, which enforces the use of
5944 an alloc_type_spec that is not necessarily a BT_DERIVED. */
5945 ts
= &code
->ext
.alloc
.ts
;
5947 /* Prepare for setting the vtab as declared. */
5950 vtab
= gfc_find_vtab (ts
);
5952 tmp
= gfc_build_addr_expr (NULL_TREE
,
5953 gfc_get_symbol_decl (vtab
));
5954 gfc_add_modify (&block
, al_vptr
,
5955 fold_convert (TREE_TYPE (al_vptr
), tmp
));
5959 /* Add assignment for string length. */
5960 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
5962 if (expr3_len
!= NULL_TREE
)
5964 gfc_add_modify (&block
, al_len
,
5965 fold_convert (TREE_TYPE (al_len
),
5967 /* When tmp_expr3_len_flag is set, then expr3_len is
5968 abused to carry the length information from the
5969 alloc_type. Clear it to prevent setting incorrect len
5970 information in future loop iterations. */
5971 if (tmp_expr3_len_flag
)
5972 /* No need to reset tmp_expr3_len_flag, because the
5973 presence of an expr3 can not change within in the
5975 expr3_len
= NULL_TREE
;
5977 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
5978 && code
->ext
.alloc
.ts
.u
.cl
->length
)
5980 /* Cover the cases where a string length is explicitly
5981 specified by a type spec for deferred length character
5982 arrays or unlimited polymorphic objects without a
5983 source= or mold= expression. */
5984 gfc_init_se (&se_sz
, NULL
);
5985 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5986 gfc_add_modify (&block
, al_len
,
5987 fold_convert (TREE_TYPE (al_len
),
5991 /* No length information needed, because type to allocate
5992 has no length. Set _len to 0. */
5993 gfc_add_modify (&block
, al_len
,
5994 fold_convert (TREE_TYPE (al_len
),
5995 integer_zero_node
));
5997 if (code
->expr3
&& !code
->expr3
->mold
)
5999 /* Initialization via SOURCE block (or static default initializer).
6000 Classes need some special handling, so catch them first. */
6001 if (expr3
!= NULL_TREE
6002 && TREE_CODE (expr3
) != POINTER_PLUS_EXPR
6003 && code
->expr3
->ts
.type
== BT_CLASS
6004 && (expr
->ts
.type
== BT_CLASS
6005 || expr
->ts
.type
== BT_DERIVED
))
6007 /* copy_class_to_class can be used for class arrays, too.
6008 It just needs to be ensured, that the decl_saved_descriptor
6009 has a way to get to the vptr. */
6011 to
= VAR_P (se
.expr
) ? se
.expr
: TREE_OPERAND (se
.expr
, 0);
6012 tmp
= gfc_copy_class_to_class (expr3
, to
,
6013 nelems
, upoly_expr
);
6015 else if (al
->expr
->ts
.type
== BT_CLASS
)
6017 gfc_actual_arglist
*actual
, *last_arg
;
6020 gfc_ref
*ref
, *dataref
;
6021 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6023 /* Do a polymorphic deep copy. */
6024 actual
= gfc_get_actual_arglist ();
6025 actual
->expr
= gfc_copy_expr (rhs
);
6026 if (rhs
->ts
.type
== BT_CLASS
)
6027 gfc_add_data_component (actual
->expr
);
6028 last_arg
= actual
->next
= gfc_get_actual_arglist ();
6029 last_arg
->expr
= gfc_copy_expr (al
->expr
);
6030 last_arg
->expr
->ts
.type
= BT_CLASS
;
6031 gfc_add_data_component (last_arg
->expr
);
6034 /* Make sure we go up through the reference chain to
6035 the _data reference, where the arrayspec is found. */
6036 for (ref
= last_arg
->expr
->ref
; ref
; ref
= ref
->next
)
6037 if (ref
->type
== REF_COMPONENT
6038 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
6041 if (dataref
&& dataref
->u
.c
.component
->as
)
6043 gfc_array_spec
*as
= dataref
->u
.c
.component
->as
;
6044 gfc_free_ref_list (dataref
->next
);
6045 dataref
->next
= NULL
;
6046 gfc_add_full_array_ref (last_arg
->expr
, as
);
6047 gfc_resolve_expr (last_arg
->expr
);
6048 gcc_assert (last_arg
->expr
->ts
.type
== BT_CLASS
6049 || last_arg
->expr
->ts
.type
== BT_DERIVED
);
6050 last_arg
->expr
->ts
.type
= BT_CLASS
;
6052 if (rhs
->ts
.type
== BT_CLASS
)
6055 ppc
= gfc_find_and_cut_at_last_class_ref (rhs
);
6057 ppc
= gfc_copy_expr (rhs
);
6058 gfc_add_vptr_component (ppc
);
6061 ppc
= gfc_lval_expr_from_sym (gfc_find_vtab (&rhs
->ts
));
6062 gfc_add_component_ref (ppc
, "_copy");
6064 ppc_code
= gfc_get_code (EXEC_CALL
);
6065 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
6066 ppc_code
->loc
= al
->expr
->where
;
6067 /* Although '_copy' is set to be elemental in class.c, it is
6068 not staying that way. Find out why, sometime.... */
6069 ppc_code
->resolved_sym
->attr
.elemental
= 1;
6070 ppc_code
->ext
.actual
= actual
;
6071 ppc_code
->expr1
= ppc
;
6072 /* Since '_copy' is elemental, the scalarizer will take care
6073 of arrays in gfc_trans_call. */
6074 tmp
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
6075 /* We need to add the
6077 al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
6079 al_vptr->copy (expr3_data, al_data);
6080 block, because al is unlimited polymorphic or a deferred
6081 length char array, whose copy routine needs the array lengths
6082 as third and fourth arguments. */
6083 if (al_len
&& UNLIMITED_POLY (code
->expr3
))
6085 tree stdcopy
, extcopy
;
6087 last_arg
->next
= gfc_get_actual_arglist ();
6088 last_arg
= last_arg
->next
;
6089 last_arg
->expr
= gfc_find_and_cut_at_last_class_ref (
6091 gfc_add_len_component (last_arg
->expr
);
6092 /* Add expr3's length. */
6093 last_arg
->next
= gfc_get_actual_arglist ();
6094 last_arg
= last_arg
->next
;
6095 if (code
->expr3
->ts
.type
== BT_CLASS
)
6098 gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6099 gfc_add_len_component (last_arg
->expr
);
6101 else if (code
->expr3
->ts
.type
== BT_CHARACTER
)
6103 gfc_copy_expr (code
->expr3
->ts
.u
.cl
->length
);
6108 extcopy
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
6110 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
6111 boolean_type_node
, expr3_len
,
6113 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6114 void_type_node
, tmp
, extcopy
, stdcopy
);
6116 gfc_free_statements (ppc_code
);
6118 gfc_free_expr (rhs
);
6122 /* Switch off automatic reallocation since we have just
6123 done the ALLOCATE. */
6124 int realloc_lhs
= flag_realloc_lhs
;
6125 flag_realloc_lhs
= 0;
6126 tmp
= gfc_trans_assignment (gfc_expr_to_initialize (expr
),
6127 e3rhs
, false, false);
6128 flag_realloc_lhs
= realloc_lhs
;
6130 gfc_add_expr_to_block (&block
, tmp
);
6132 else if (code
->expr3
&& code
->expr3
->mold
6133 && code
->expr3
->ts
.type
== BT_CLASS
)
6135 /* Since the _vptr has already been assigned to the allocate
6136 object, we can use gfc_copy_class_to_class in its
6137 initialization mode. */
6138 tmp
= TREE_OPERAND (se
.expr
, 0);
6139 tmp
= gfc_copy_class_to_class (NULL_TREE
, tmp
, nelems
,
6141 gfc_add_expr_to_block (&block
, tmp
);
6144 gfc_free_expr (expr
);
6151 gfc_free_symbol (newsym
->n
.sym
);
6154 gfc_free_expr (e3rhs
);
6159 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6160 gfc_add_expr_to_block (&block
, tmp
);
6163 /* ERRMSG - only useful if STAT is present. */
6164 if (code
->expr1
&& code
->expr2
)
6166 const char *msg
= "Attempt to allocate an allocated object";
6167 tree slen
, dlen
, errmsg_str
;
6168 stmtblock_t errmsg_block
;
6170 gfc_init_block (&errmsg_block
);
6172 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6173 gfc_add_modify (&errmsg_block
, errmsg_str
,
6174 gfc_build_addr_expr (pchar_type_node
,
6175 gfc_build_localized_cstring_const (msg
)));
6177 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6178 dlen
= gfc_get_expr_charlen (code
->expr2
);
6179 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6180 TREE_TYPE (slen
), dlen
, slen
);
6182 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6183 code
->expr2
->ts
.kind
,
6185 gfc_default_character_kind
);
6186 dlen
= gfc_finish_block (&errmsg_block
);
6188 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6189 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6191 tmp
= build3_v (COND_EXPR
, tmp
,
6192 dlen
, build_empty_stmt (input_location
));
6194 gfc_add_expr_to_block (&block
, tmp
);
6200 if (TREE_USED (label_finish
))
6202 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6203 gfc_add_expr_to_block (&block
, tmp
);
6206 gfc_init_se (&se
, NULL
);
6207 gfc_conv_expr_lhs (&se
, code
->expr1
);
6208 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6209 gfc_add_modify (&block
, se
.expr
, tmp
);
6212 gfc_add_block_to_block (&block
, &se
.post
);
6213 gfc_add_block_to_block (&block
, &post
);
6215 return gfc_finish_block (&block
);
6219 /* Translate a DEALLOCATE statement. */
6222 gfc_trans_deallocate (gfc_code
*code
)
6226 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6227 tree label_finish
, label_errmsg
;
6230 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6231 label_finish
= label_errmsg
= NULL_TREE
;
6233 gfc_start_block (&block
);
6235 /* Count the number of failed deallocations. If deallocate() was
6236 called with STAT= , then set STAT to the count. If deallocate
6237 was called with ERRMSG, then set ERRMG to a string. */
6240 tree gfc_int4_type_node
= gfc_get_int_type (4);
6242 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6243 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6245 /* GOTO destinations. */
6246 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6247 label_finish
= gfc_build_label_decl (NULL_TREE
);
6248 TREE_USED (label_finish
) = 0;
6251 /* Set ERRMSG - only needed if STAT is available. */
6252 if (code
->expr1
&& code
->expr2
)
6254 gfc_init_se (&se
, NULL
);
6255 se
.want_pointer
= 1;
6256 gfc_conv_expr_lhs (&se
, code
->expr2
);
6258 errlen
= se
.string_length
;
6261 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6263 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6264 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6266 if (expr
->ts
.type
== BT_CLASS
)
6267 gfc_add_data_component (expr
);
6269 gfc_init_se (&se
, NULL
);
6270 gfc_start_block (&se
.pre
);
6272 se
.want_pointer
= 1;
6273 se
.descriptor_only
= 1;
6274 gfc_conv_expr (&se
, expr
);
6276 if (expr
->rank
|| gfc_is_coarray (expr
))
6280 if (gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.u
.derived
->attr
.alloc_comp
6281 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6283 gfc_ref
*last
= NULL
;
6285 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6286 if (ref
->type
== REF_COMPONENT
)
6289 /* Do not deallocate the components of a derived type
6290 ultimate pointer component. */
6291 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6292 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6294 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
.expr
,
6296 gfc_add_expr_to_block (&se
.pre
, tmp
);
6300 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6302 tmp
= gfc_array_deallocate (se
.expr
, pstat
, errmsg
, errlen
,
6303 label_finish
, expr
);
6304 gfc_add_expr_to_block (&se
.pre
, tmp
);
6306 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6307 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6308 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6311 /* class.c(finalize_component) generates these, when a
6312 finalizable entity has a non-allocatable derived type array
6313 component, which has allocatable components. Obtain the
6314 derived type of the array and deallocate the allocatable
6316 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6318 if (ref
->u
.c
.component
->attr
.dimension
6319 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6323 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6324 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6327 tmp
= gfc_deallocate_alloc_comp
6328 (ref
->u
.c
.component
->ts
.u
.derived
,
6329 se
.expr
, expr
->rank
);
6330 gfc_add_expr_to_block (&se
.pre
, tmp
);
6334 if (al
->expr
->ts
.type
== BT_CLASS
)
6336 gfc_reset_vptr (&se
.pre
, al
->expr
);
6337 if (UNLIMITED_POLY (al
->expr
)
6338 || (al
->expr
->ts
.type
== BT_DERIVED
6339 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6340 /* Clear _len, too. */
6341 gfc_reset_len (&se
.pre
, al
->expr
);
6346 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, false,
6347 al
->expr
, al
->expr
->ts
);
6348 gfc_add_expr_to_block (&se
.pre
, tmp
);
6350 /* Set to zero after deallocation. */
6351 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6353 build_int_cst (TREE_TYPE (se
.expr
), 0));
6354 gfc_add_expr_to_block (&se
.pre
, tmp
);
6356 if (al
->expr
->ts
.type
== BT_CLASS
)
6358 gfc_reset_vptr (&se
.pre
, al
->expr
);
6359 if (UNLIMITED_POLY (al
->expr
)
6360 || (al
->expr
->ts
.type
== BT_DERIVED
6361 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6362 /* Clear _len, too. */
6363 gfc_reset_len (&se
.pre
, al
->expr
);
6371 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6372 build_int_cst (TREE_TYPE (stat
), 0));
6373 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6374 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6375 build1_v (GOTO_EXPR
, label_errmsg
),
6376 build_empty_stmt (input_location
));
6377 gfc_add_expr_to_block (&se
.pre
, tmp
);
6380 tmp
= gfc_finish_block (&se
.pre
);
6381 gfc_add_expr_to_block (&block
, tmp
);
6382 gfc_free_expr (expr
);
6387 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6388 gfc_add_expr_to_block (&block
, tmp
);
6391 /* Set ERRMSG - only needed if STAT is available. */
6392 if (code
->expr1
&& code
->expr2
)
6394 const char *msg
= "Attempt to deallocate an unallocated object";
6395 stmtblock_t errmsg_block
;
6396 tree errmsg_str
, slen
, dlen
, cond
;
6398 gfc_init_block (&errmsg_block
);
6400 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6401 gfc_add_modify (&errmsg_block
, errmsg_str
,
6402 gfc_build_addr_expr (pchar_type_node
,
6403 gfc_build_localized_cstring_const (msg
)));
6404 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6405 dlen
= gfc_get_expr_charlen (code
->expr2
);
6407 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6408 slen
, errmsg_str
, gfc_default_character_kind
);
6409 tmp
= gfc_finish_block (&errmsg_block
);
6411 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6412 build_int_cst (TREE_TYPE (stat
), 0));
6413 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6414 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6415 build_empty_stmt (input_location
));
6417 gfc_add_expr_to_block (&block
, tmp
);
6420 if (code
->expr1
&& TREE_USED (label_finish
))
6422 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6423 gfc_add_expr_to_block (&block
, tmp
);
6429 gfc_init_se (&se
, NULL
);
6430 gfc_conv_expr_lhs (&se
, code
->expr1
);
6431 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6432 gfc_add_modify (&block
, se
.expr
, tmp
);
6435 return gfc_finish_block (&block
);
6438 #include "gt-fortran-trans-stmt.h"