1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
27 #include "coretypes.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
37 #include "dependency.h"
40 typedef struct iter_info
46 struct iter_info *next;
50 typedef struct forall_info
57 struct forall_info *prev_nest;
61 static void gfc_trans_where_2 (gfc_code *, tree, bool,
62 forall_info *, stmtblock_t *);
64 /* Translate a F95 label number to a LABEL_EXPR. */
67 gfc_trans_label_here (gfc_code * code)
69 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
73 /* Given a variable expression which has been ASSIGNed to, find the decl
74 containing the auxiliary variables. For variables in common blocks this
78 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
80 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
81 gfc_conv_expr (se, expr);
82 /* Deals with variable in common block. Get the field declaration. */
83 if (TREE_CODE (se->expr) == COMPONENT_REF)
84 se->expr = TREE_OPERAND (se->expr, 1);
85 /* Deals with dummy argument. Get the parameter declaration. */
86 else if (TREE_CODE (se->expr) == INDIRECT_REF)
87 se->expr = TREE_OPERAND (se->expr, 0);
90 /* Translate a label assignment statement. */
93 gfc_trans_label_assign (gfc_code * code)
102 /* Start a new block. */
103 gfc_init_se (&se, NULL);
104 gfc_start_block (&se.pre);
105 gfc_conv_label_variable (&se, code->expr1);
107 len = GFC_DECL_STRING_LEN (se.expr);
108 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
110 label_tree = gfc_get_label_decl (code->label1);
112 if (code->label1->defined == ST_LABEL_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 = sym->formal;
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, gfc_walk_expr (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),
341 gfc_add_expr_to_block (&se->post, tmp);
343 /* parmse.pre is already added above. */
344 gfc_add_block_to_block (&se->post, &parmse.post);
345 gfc_add_block_to_block (&se->post, &temp_post);
351 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
354 gfc_trans_call (gfc_code * code, bool dependency_check,
355 tree mask, tree count1, bool invert)
359 int has_alternate_specifier;
360 gfc_dep_check check_variable;
361 tree index = NULL_TREE;
362 tree maskexpr = NULL_TREE;
365 /* A CALL starts a new block because the actual arguments may have to
366 be evaluated first. */
367 gfc_init_se (&se, NULL);
368 gfc_start_block (&se.pre);
370 gcc_assert (code->resolved_sym);
372 ss = gfc_ss_terminator;
373 if (code->resolved_sym->attr.elemental)
374 ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
375 code->expr1, GFC_SS_REFERENCE);
377 /* Is not an elemental subroutine call with array valued arguments. */
378 if (ss == gfc_ss_terminator)
381 /* Translate the call. */
382 has_alternate_specifier
383 = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
386 /* A subroutine without side-effect, by definition, does nothing! */
387 TREE_SIDE_EFFECTS (se.expr) = 1;
389 /* Chain the pieces together and return the block. */
390 if (has_alternate_specifier)
392 gfc_code *select_code;
394 select_code = code->next;
395 gcc_assert(select_code->op == EXEC_SELECT);
396 sym = select_code->expr1->symtree->n.sym;
397 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
398 if (sym->backend_decl == NULL)
399 sym->backend_decl = gfc_get_symbol_decl (sym);
400 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
403 gfc_add_expr_to_block (&se.pre, se.expr);
405 gfc_add_block_to_block (&se.pre, &se.post);
410 /* An elemental subroutine call with array valued arguments has
418 /* gfc_walk_elemental_function_args renders the ss chain in the
419 reverse order to the actual argument order. */
420 ss = gfc_reverse_ss (ss);
422 /* Initialize the loop. */
423 gfc_init_se (&loopse, NULL);
424 gfc_init_loopinfo (&loop);
425 gfc_add_ss_to_loop (&loop, ss);
427 gfc_conv_ss_startstride (&loop);
428 /* TODO: gfc_conv_loop_setup generates a temporary for vector
429 subscripts. This could be prevented in the elemental case
430 as temporaries are handled separatedly
431 (below in gfc_conv_elemental_dependencies). */
432 gfc_conv_loop_setup (&loop, &code->expr1->where);
433 gfc_mark_ss_chain_used (ss, 1);
435 /* Convert the arguments, checking for dependencies. */
436 gfc_copy_loopinfo_to_se (&loopse, &loop);
439 /* For operator assignment, do dependency checking. */
440 if (dependency_check)
441 check_variable = ELEM_CHECK_VARIABLE;
443 check_variable = ELEM_DONT_CHECK_VARIABLE;
445 gfc_init_se (&depse, NULL);
446 gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
447 code->ext.actual, check_variable);
449 gfc_add_block_to_block (&loop.pre, &depse.pre);
450 gfc_add_block_to_block (&loop.post, &depse.post);
452 /* Generate the loop body. */
453 gfc_start_scalarized_body (&loop, &body);
454 gfc_init_block (&block);
458 /* Form the mask expression according to the mask. */
460 maskexpr = gfc_build_array_ref (mask, index, NULL);
462 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
463 TREE_TYPE (maskexpr), maskexpr);
466 /* Add the subroutine call to the block. */
467 gfc_conv_procedure_call (&loopse, code->resolved_sym,
468 code->ext.actual, code->expr1, NULL);
472 tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
473 build_empty_stmt (input_location));
474 gfc_add_expr_to_block (&loopse.pre, tmp);
475 tmp = fold_build2_loc (input_location, PLUS_EXPR,
476 gfc_array_index_type,
477 count1, gfc_index_one_node);
478 gfc_add_modify (&loopse.pre, count1, tmp);
481 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
483 gfc_add_block_to_block (&block, &loopse.pre);
484 gfc_add_block_to_block (&block, &loopse.post);
486 /* Finish up the loop block and the loop. */
487 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
488 gfc_trans_scalarizing_loops (&loop, &body);
489 gfc_add_block_to_block (&se.pre, &loop.pre);
490 gfc_add_block_to_block (&se.pre, &loop.post);
491 gfc_add_block_to_block (&se.pre, &se.post);
492 gfc_cleanup_loop (&loop);
495 return gfc_finish_block (&se.pre);
499 /* Translate the RETURN statement. */
502 gfc_trans_return (gfc_code * code)
510 /* If code->expr is not NULL, this return statement must appear
511 in a subroutine and current_fake_result_decl has already
514 result = gfc_get_fake_result_decl (NULL, 0);
517 gfc_warning ("An alternate return at %L without a * dummy argument",
518 &code->expr1->where);
519 return gfc_generate_return ();
522 /* Start a new block for this statement. */
523 gfc_init_se (&se, NULL);
524 gfc_start_block (&se.pre);
526 gfc_conv_expr (&se, code->expr1);
528 /* Note that the actually returned expression is a simple value and
529 does not depend on any pointers or such; thus we can clean-up with
530 se.post before returning. */
531 tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
532 result, fold_convert (TREE_TYPE (result),
534 gfc_add_expr_to_block (&se.pre, tmp);
535 gfc_add_block_to_block (&se.pre, &se.post);
537 tmp = gfc_generate_return ();
538 gfc_add_expr_to_block (&se.pre, tmp);
539 return gfc_finish_block (&se.pre);
542 return gfc_generate_return ();
546 /* Translate the PAUSE statement. We have to translate this statement
547 to a runtime library call. */
550 gfc_trans_pause (gfc_code * code)
552 tree gfc_int4_type_node = gfc_get_int_type (4);
556 /* Start a new block for this statement. */
557 gfc_init_se (&se, NULL);
558 gfc_start_block (&se.pre);
561 if (code->expr1 == NULL)
563 tmp = build_int_cst (gfc_int4_type_node, 0);
564 tmp = build_call_expr_loc (input_location,
565 gfor_fndecl_pause_string, 2,
566 build_int_cst (pchar_type_node, 0), tmp);
568 else if (code->expr1->ts.type == BT_INTEGER)
570 gfc_conv_expr (&se, code->expr1);
571 tmp = build_call_expr_loc (input_location,
572 gfor_fndecl_pause_numeric, 1,
573 fold_convert (gfc_int4_type_node, se.expr));
577 gfc_conv_expr_reference (&se, code->expr1);
578 tmp = build_call_expr_loc (input_location,
579 gfor_fndecl_pause_string, 2,
580 se.expr, se.string_length);
583 gfc_add_expr_to_block (&se.pre, tmp);
585 gfc_add_block_to_block (&se.pre, &se.post);
587 return gfc_finish_block (&se.pre);
591 /* Translate the STOP statement. We have to translate this statement
592 to a runtime library call. */
595 gfc_trans_stop (gfc_code *code, bool error_stop)
597 tree gfc_int4_type_node = gfc_get_int_type (4);
601 /* Start a new block for this statement. */
602 gfc_init_se (&se, NULL);
603 gfc_start_block (&se.pre);
605 if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
607 /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
608 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
609 tmp = build_call_expr_loc (input_location, tmp, 0);
610 gfc_add_expr_to_block (&se.pre, tmp);
612 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
613 gfc_add_expr_to_block (&se.pre, tmp);
616 if (code->expr1 == NULL)
618 tmp = build_int_cst (gfc_int4_type_node, 0);
619 tmp = build_call_expr_loc (input_location,
621 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
622 ? gfor_fndecl_caf_error_stop_str
623 : gfor_fndecl_error_stop_string)
624 : gfor_fndecl_stop_string,
625 2, build_int_cst (pchar_type_node, 0), tmp);
627 else if (code->expr1->ts.type == BT_INTEGER)
629 gfc_conv_expr (&se, code->expr1);
630 tmp = build_call_expr_loc (input_location,
632 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
633 ? gfor_fndecl_caf_error_stop
634 : gfor_fndecl_error_stop_numeric)
635 : gfor_fndecl_stop_numeric_f08, 1,
636 fold_convert (gfc_int4_type_node, se.expr));
640 gfc_conv_expr_reference (&se, code->expr1);
641 tmp = build_call_expr_loc (input_location,
643 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
644 ? gfor_fndecl_caf_error_stop_str
645 : gfor_fndecl_error_stop_string)
646 : gfor_fndecl_stop_string,
647 2, se.expr, se.string_length);
650 gfc_add_expr_to_block (&se.pre, tmp);
652 gfc_add_block_to_block (&se.pre, &se.post);
654 return gfc_finish_block (&se.pre);
659 gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
662 tree stat = NULL_TREE, lock_acquired = NULL_TREE;
664 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
665 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
666 if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
669 gfc_init_se (&se, NULL);
670 gfc_start_block (&se.pre);
674 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
675 gfc_init_se (&argse, NULL);
676 gfc_conv_expr_val (&argse, code->expr2);
682 gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
683 gfc_init_se (&argse, NULL);
684 gfc_conv_expr_val (&argse, code->expr4);
685 lock_acquired = argse.expr;
688 if (stat != NULL_TREE)
689 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
691 if (lock_acquired != NULL_TREE)
692 gfc_add_modify (&se.pre, lock_acquired,
693 fold_convert (TREE_TYPE (lock_acquired),
696 return gfc_finish_block (&se.pre);
701 gfc_trans_sync (gfc_code *code, gfc_exec_op type)
705 tree images = NULL_TREE, stat = NULL_TREE,
706 errmsg = NULL_TREE, errmsglen = NULL_TREE;
708 /* Short cut: For single images without bound checking or without STAT=,
709 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
710 if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
711 && gfc_option.coarray != GFC_FCOARRAY_LIB)
714 gfc_init_se (&se, NULL);
715 gfc_start_block (&se.pre);
717 if (code->expr1 && code->expr1->rank == 0)
719 gfc_init_se (&argse, NULL);
720 gfc_conv_expr_val (&argse, code->expr1);
726 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
727 gfc_init_se (&argse, NULL);
728 gfc_conv_expr_val (&argse, code->expr2);
732 stat = null_pointer_node;
734 if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
735 && type != EXEC_SYNC_MEMORY)
737 gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
738 gfc_init_se (&argse, NULL);
739 gfc_conv_expr (&argse, code->expr3);
740 gfc_conv_string_parameter (&argse);
741 errmsg = gfc_build_addr_expr (NULL, argse.expr);
742 errmsglen = argse.string_length;
744 else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
746 errmsg = null_pointer_node;
747 errmsglen = build_int_cst (integer_type_node, 0);
750 /* Check SYNC IMAGES(imageset) for valid image index.
751 FIXME: Add a check for image-set arrays. */
752 if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
753 && code->expr1->rank == 0)
756 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
757 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
758 images, build_int_cst (TREE_TYPE (images), 1));
762 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
763 images, gfort_gvar_caf_num_images);
764 cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
766 build_int_cst (TREE_TYPE (images), 1));
767 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
768 boolean_type_node, cond, cond2);
770 gfc_trans_runtime_check (true, false, cond, &se.pre,
771 &code->expr1->where, "Invalid image number "
773 fold_convert (integer_type_node, se.expr));
776 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
777 image control statements SYNC IMAGES and SYNC ALL. */
778 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
780 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
781 tmp = build_call_expr_loc (input_location, tmp, 0);
782 gfc_add_expr_to_block (&se.pre, tmp);
785 if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
787 /* Set STAT to zero. */
789 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
791 else if (type == EXEC_SYNC_ALL)
793 /* SYNC ALL => stat == null_pointer_node
794 SYNC ALL(stat=s) => stat has an integer type
796 If "stat" has the wrong integer type, use a temp variable of
797 the right type and later cast the result back into "stat". */
798 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
800 if (TREE_TYPE (stat) == integer_type_node)
801 stat = gfc_build_addr_expr (NULL, stat);
803 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
804 3, stat, errmsg, errmsglen);
805 gfc_add_expr_to_block (&se.pre, tmp);
809 tree tmp_stat = gfc_create_var (integer_type_node, "stat");
811 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
812 3, gfc_build_addr_expr (NULL, tmp_stat),
814 gfc_add_expr_to_block (&se.pre, tmp);
816 gfc_add_modify (&se.pre, stat,
817 fold_convert (TREE_TYPE (stat), tmp_stat));
824 gcc_assert (type == EXEC_SYNC_IMAGES);
828 len = build_int_cst (integer_type_node, -1);
829 images = null_pointer_node;
831 else if (code->expr1->rank == 0)
833 len = build_int_cst (integer_type_node, 1);
834 images = gfc_build_addr_expr (NULL_TREE, images);
839 if (code->expr1->ts.kind != gfc_c_int_kind)
840 gfc_fatal_error ("Sorry, only support for integer kind %d "
841 "implemented for image-set at %L",
842 gfc_c_int_kind, &code->expr1->where);
844 gfc_conv_array_parameter (&se, code->expr1,
845 gfc_walk_expr (code->expr1), true, NULL,
849 tmp = gfc_typenode_for_spec (&code->expr1->ts);
850 if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
851 tmp = gfc_get_element_type (tmp);
853 len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
854 TREE_TYPE (len), len,
855 fold_convert (TREE_TYPE (len),
856 TYPE_SIZE_UNIT (tmp)));
857 len = fold_convert (integer_type_node, len);
860 /* SYNC IMAGES(imgs) => stat == null_pointer_node
861 SYNC IMAGES(imgs,stat=s) => stat has an integer type
863 If "stat" has the wrong integer type, use a temp variable of
864 the right type and later cast the result back into "stat". */
865 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
867 if (TREE_TYPE (stat) == integer_type_node)
868 stat = gfc_build_addr_expr (NULL, stat);
870 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
871 5, fold_convert (integer_type_node, len),
872 images, stat, errmsg, errmsglen);
873 gfc_add_expr_to_block (&se.pre, tmp);
877 tree tmp_stat = gfc_create_var (integer_type_node, "stat");
879 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
880 5, fold_convert (integer_type_node, len),
881 images, gfc_build_addr_expr (NULL, tmp_stat),
883 gfc_add_expr_to_block (&se.pre, tmp);
885 gfc_add_modify (&se.pre, stat,
886 fold_convert (TREE_TYPE (stat), tmp_stat));
890 return gfc_finish_block (&se.pre);
894 /* Generate GENERIC for the IF construct. This function also deals with
895 the simple IF statement, because the front end translates the IF
896 statement into an IF construct.
928 where COND_S is the simplified version of the predicate. PRE_COND_S
929 are the pre side-effects produced by the translation of the
931 We need to build the chain recursively otherwise we run into
932 problems with folding incomplete statements. */
935 gfc_trans_if_1 (gfc_code * code)
942 /* Check for an unconditional ELSE clause. */
944 return gfc_trans_code (code->next);
946 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
947 gfc_init_se (&if_se, NULL);
948 gfc_start_block (&if_se.pre);
950 /* Calculate the IF condition expression. */
951 if (code->expr1->where.lb)
953 gfc_save_backend_locus (&saved_loc);
954 gfc_set_backend_locus (&code->expr1->where);
957 gfc_conv_expr_val (&if_se, code->expr1);
959 if (code->expr1->where.lb)
960 gfc_restore_backend_locus (&saved_loc);
962 /* Translate the THEN clause. */
963 stmt = gfc_trans_code (code->next);
965 /* Translate the ELSE clause. */
967 elsestmt = gfc_trans_if_1 (code->block);
969 elsestmt = build_empty_stmt (input_location);
971 /* Build the condition expression and add it to the condition block. */
972 loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
973 stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
976 gfc_add_expr_to_block (&if_se.pre, stmt);
978 /* Finish off this statement. */
979 return gfc_finish_block (&if_se.pre);
983 gfc_trans_if (gfc_code * code)
988 /* Create exit label so it is available for trans'ing the body code. */
989 exit_label = gfc_build_label_decl (NULL_TREE);
990 code->exit_label = exit_label;
992 /* Translate the actual code in code->block. */
993 gfc_init_block (&body);
994 gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
996 /* Add exit label. */
997 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
999 return gfc_finish_block (&body);
1003 /* Translate an arithmetic IF expression.
1005 IF (cond) label1, label2, label3 translates to
1017 An optimized version can be generated in case of equal labels.
1018 E.g., if label1 is equal to label2, we can translate it to
1027 gfc_trans_arithmetic_if (gfc_code * code)
1035 /* Start a new block. */
1036 gfc_init_se (&se, NULL);
1037 gfc_start_block (&se.pre);
1039 /* Pre-evaluate COND. */
1040 gfc_conv_expr_val (&se, code->expr1);
1041 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1043 /* Build something to compare with. */
1044 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
1046 if (code->label1->value != code->label2->value)
1048 /* If (cond < 0) take branch1 else take branch2.
1049 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1050 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1051 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
1053 if (code->label1->value != code->label3->value)
1054 tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1057 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1060 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1061 tmp, branch1, branch2);
1064 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1066 if (code->label1->value != code->label3->value
1067 && code->label2->value != code->label3->value)
1069 /* if (cond <= 0) take branch1 else take branch2. */
1070 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
1071 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1073 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1074 tmp, branch1, branch2);
1077 /* Append the COND_EXPR to the evaluation of COND, and return. */
1078 gfc_add_expr_to_block (&se.pre, branch1);
1079 return gfc_finish_block (&se.pre);
1083 /* Translate a CRITICAL block. */
1085 gfc_trans_critical (gfc_code *code)
1090 gfc_start_block (&block);
1092 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1094 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
1095 gfc_add_expr_to_block (&block, tmp);
1098 tmp = gfc_trans_code (code->block->next);
1099 gfc_add_expr_to_block (&block, tmp);
1101 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1103 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
1105 gfc_add_expr_to_block (&block, tmp);
1109 return gfc_finish_block (&block);
1113 /* Do proper initialization for ASSOCIATE names. */
1116 trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
1122 gcc_assert (sym->assoc);
1123 e = sym->assoc->target;
1125 class_target = (e->expr_type == EXPR_VARIABLE)
1126 && (gfc_is_class_scalar_expr (e)
1127 || gfc_is_class_array_ref (e, NULL));
1129 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1130 to array temporary) for arrays with either unknown shape or if associating
1132 if (sym->attr.dimension && !class_target
1133 && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
1139 desc = sym->backend_decl;
1141 /* If association is to an expression, evaluate it and create temporary.
1142 Otherwise, get descriptor of target for pointer assignment. */
1143 gfc_init_se (&se, NULL);
1144 ss = gfc_walk_expr (e);
1145 if (sym->assoc->variable)
1147 se.direct_byref = 1;
1150 gfc_conv_expr_descriptor (&se, e, ss);
1152 /* If we didn't already do the pointer assignment, set associate-name
1153 descriptor to the one generated for the temporary. */
1154 if (!sym->assoc->variable)
1158 gfc_add_modify (&se.pre, desc, se.expr);
1160 /* The generated descriptor has lower bound zero (as array
1161 temporary), shift bounds so we get lower bounds of 1. */
1162 for (dim = 0; dim < e->rank; ++dim)
1163 gfc_conv_shift_descriptor_lbound (&se.pre, desc,
1164 dim, gfc_index_one_node);
1167 /* Done, register stuff as init / cleanup code. */
1168 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
1169 gfc_finish_block (&se.post));
1172 /* CLASS arrays just need the descriptor to be directly assigned. */
1173 else if (class_target && sym->attr.dimension)
1177 gfc_init_se (&se, NULL);
1178 se.descriptor_only = 1;
1179 gfc_conv_expr (&se, e);
1181 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
1182 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
1184 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
1186 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1187 gfc_finish_block (&se.post));
1190 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1191 else if (gfc_is_associate_pointer (sym))
1195 gcc_assert (!sym->attr.dimension);
1197 gfc_init_se (&se, NULL);
1198 gfc_conv_expr (&se, e);
1200 tmp = TREE_TYPE (sym->backend_decl);
1201 tmp = gfc_build_addr_expr (tmp, se.expr);
1202 gfc_add_modify (&se.pre, sym->backend_decl, tmp);
1204 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1205 gfc_finish_block (&se.post));
1208 /* Do a simple assignment. This is for scalar expressions, where we
1209 can simply use expression assignment. */
1214 lhs = gfc_lval_expr_from_sym (sym);
1215 tmp = gfc_trans_assignment (lhs, e, false, true);
1216 gfc_add_init_cleanup (block, tmp, NULL_TREE);
1221 /* Translate a BLOCK construct. This is basically what we would do for a
1225 gfc_trans_block_construct (gfc_code* code)
1229 gfc_wrapped_block block;
1232 gfc_association_list *ass;
1234 ns = code->ext.block.ns;
1236 sym = ns->proc_name;
1239 /* Process local variables. */
1240 gcc_assert (!sym->tlink);
1242 gfc_process_block_locals (ns);
1244 /* Generate code including exit-label. */
1245 gfc_init_block (&body);
1246 exit_label = gfc_build_label_decl (NULL_TREE);
1247 code->exit_label = exit_label;
1248 gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
1249 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1251 /* Finish everything. */
1252 gfc_start_wrapped_block (&block, gfc_finish_block (&body));
1253 gfc_trans_deferred_vars (sym, &block);
1254 for (ass = code->ext.block.assoc; ass; ass = ass->next)
1255 trans_associate_var (ass->st->n.sym, &block);
1257 return gfc_finish_wrapped_block (&block);
1261 /* Translate the simple DO construct. This is where the loop variable has
1262 integer type and step +-1. We can't use this in the general case
1263 because integer overflow and floating point errors could give incorrect
1265 We translate a do loop from:
1267 DO dovar = from, to, step
1273 [Evaluate loop bounds and step]
1275 if ((step > 0) ? (dovar <= to) : (dovar => to))
1281 cond = (dovar == to);
1283 if (cond) goto end_label;
1288 This helps the optimizers by avoiding the extra induction variable
1289 used in the general case. */
1292 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
1293 tree from, tree to, tree step, tree exit_cond)
1299 tree saved_dovar = NULL;
1304 type = TREE_TYPE (dovar);
1306 loc = code->ext.iterator->start->where.lb->location;
1308 /* Initialize the DO variable: dovar = from. */
1309 gfc_add_modify_loc (loc, pblock, dovar,
1310 fold_convert (TREE_TYPE(dovar), from));
1312 /* Save value for do-tinkering checking. */
1313 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1315 saved_dovar = gfc_create_var (type, ".saved_dovar");
1316 gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
1319 /* Cycle and exit statements are implemented with gotos. */
1320 cycle_label = gfc_build_label_decl (NULL_TREE);
1321 exit_label = gfc_build_label_decl (NULL_TREE);
1323 /* Put the labels where they can be found later. See gfc_trans_do(). */
1324 code->cycle_label = cycle_label;
1325 code->exit_label = exit_label;
1328 gfc_start_block (&body);
1330 /* Main loop body. */
1331 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1332 gfc_add_expr_to_block (&body, tmp);
1334 /* Label for cycle statements (if needed). */
1335 if (TREE_USED (cycle_label))
1337 tmp = build1_v (LABEL_EXPR, cycle_label);
1338 gfc_add_expr_to_block (&body, tmp);
1341 /* Check whether someone has modified the loop variable. */
1342 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1344 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
1345 dovar, saved_dovar);
1346 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1347 "Loop variable has been modified");
1350 /* Exit the loop if there is an I/O result condition or error. */
1353 tmp = build1_v (GOTO_EXPR, exit_label);
1354 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1356 build_empty_stmt (loc));
1357 gfc_add_expr_to_block (&body, tmp);
1360 /* Evaluate the loop condition. */
1361 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
1363 cond = gfc_evaluate_now_loc (loc, cond, &body);
1365 /* Increment the loop variable. */
1366 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1367 gfc_add_modify_loc (loc, &body, dovar, tmp);
1369 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1370 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1372 /* The loop exit. */
1373 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1374 TREE_USED (exit_label) = 1;
1375 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1376 cond, tmp, build_empty_stmt (loc));
1377 gfc_add_expr_to_block (&body, tmp);
1379 /* Finish the loop body. */
1380 tmp = gfc_finish_block (&body);
1381 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1383 /* Only execute the loop if the number of iterations is positive. */
1384 if (tree_int_cst_sgn (step) > 0)
1385 cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
1388 cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
1390 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
1391 build_empty_stmt (loc));
1392 gfc_add_expr_to_block (pblock, tmp);
1394 /* Add the exit label. */
1395 tmp = build1_v (LABEL_EXPR, exit_label);
1396 gfc_add_expr_to_block (pblock, tmp);
1398 return gfc_finish_block (pblock);
1401 /* Translate the DO construct. This obviously is one of the most
1402 important ones to get right with any compiler, but especially
1405 We special case some loop forms as described in gfc_trans_simple_do.
1406 For other cases we implement them with a separate loop count,
1407 as described in the standard.
1409 We translate a do loop from:
1411 DO dovar = from, to, step
1417 [evaluate loop bounds and step]
1418 empty = (step > 0 ? to < from : to > from);
1419 countm1 = (to - from) / step;
1421 if (empty) goto exit_label;
1427 if (countm1 ==0) goto exit_label;
1432 countm1 is an unsigned integer. It is equal to the loop count minus one,
1433 because the loop count itself can overflow. */
1436 gfc_trans_do (gfc_code * code, tree exit_cond)
1440 tree saved_dovar = NULL;
1456 gfc_start_block (&block);
1458 loc = code->ext.iterator->start->where.lb->location;
1460 /* Evaluate all the expressions in the iterator. */
1461 gfc_init_se (&se, NULL);
1462 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1463 gfc_add_block_to_block (&block, &se.pre);
1465 type = TREE_TYPE (dovar);
1467 gfc_init_se (&se, NULL);
1468 gfc_conv_expr_val (&se, code->ext.iterator->start);
1469 gfc_add_block_to_block (&block, &se.pre);
1470 from = gfc_evaluate_now (se.expr, &block);
1472 gfc_init_se (&se, NULL);
1473 gfc_conv_expr_val (&se, code->ext.iterator->end);
1474 gfc_add_block_to_block (&block, &se.pre);
1475 to = gfc_evaluate_now (se.expr, &block);
1477 gfc_init_se (&se, NULL);
1478 gfc_conv_expr_val (&se, code->ext.iterator->step);
1479 gfc_add_block_to_block (&block, &se.pre);
1480 step = gfc_evaluate_now (se.expr, &block);
1482 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1484 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
1485 build_zero_cst (type));
1486 gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
1487 "DO step value is zero");
1490 /* Special case simple loops. */
1491 if (TREE_CODE (type) == INTEGER_TYPE
1492 && (integer_onep (step)
1493 || tree_int_cst_equal (step, integer_minus_one_node)))
1494 return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
1496 pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
1497 build_zero_cst (type));
1499 if (TREE_CODE (type) == INTEGER_TYPE)
1500 utype = unsigned_type_for (type);
1502 utype = unsigned_type_for (gfc_array_index_type);
1503 countm1 = gfc_create_var (utype, "countm1");
1505 /* Cycle and exit statements are implemented with gotos. */
1506 cycle_label = gfc_build_label_decl (NULL_TREE);
1507 exit_label = gfc_build_label_decl (NULL_TREE);
1508 TREE_USED (exit_label) = 1;
1510 /* Put these labels where they can be found later. */
1511 code->cycle_label = cycle_label;
1512 code->exit_label = exit_label;
1514 /* Initialize the DO variable: dovar = from. */
1515 gfc_add_modify (&block, dovar, from);
1517 /* Save value for do-tinkering checking. */
1518 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1520 saved_dovar = gfc_create_var (type, ".saved_dovar");
1521 gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
1524 /* Initialize loop count and jump to exit label if the loop is empty.
1525 This code is executed before we enter the loop body. We generate:
1526 step_sign = sign(1,step);
1537 countm1 = (to*step_sign - from*step_sign) / (step*step_sign);
1541 if (TREE_CODE (type) == INTEGER_TYPE)
1543 tree pos, neg, step_sign, to2, from2, step2;
1545 /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */
1547 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
1548 build_int_cst (TREE_TYPE (step), 0));
1549 step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
1550 build_int_cst (type, -1),
1551 build_int_cst (type, 1));
1553 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
1554 pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1555 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1557 build_empty_stmt (loc));
1559 tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to,
1561 neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1562 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1564 build_empty_stmt (loc));
1565 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1566 pos_step, pos, neg);
1568 gfc_add_expr_to_block (&block, tmp);
1570 /* Calculate the loop count. to-from can overflow, so
1571 we cast to unsigned. */
1573 to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to);
1574 from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from);
1575 step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step);
1576 step2 = fold_convert (utype, step2);
1577 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2);
1578 tmp = fold_convert (utype, tmp);
1579 tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2);
1580 tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp);
1581 gfc_add_expr_to_block (&block, tmp);
1585 /* TODO: We could use the same width as the real type.
1586 This would probably cause more problems that it solves
1587 when we implement "long double" types. */
1589 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
1590 tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
1591 tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
1592 gfc_add_modify (&block, countm1, tmp);
1594 /* We need a special check for empty loops:
1595 empty = (step > 0 ? to < from : to > from); */
1596 tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
1597 fold_build2_loc (loc, LT_EXPR,
1598 boolean_type_node, to, from),
1599 fold_build2_loc (loc, GT_EXPR,
1600 boolean_type_node, to, from));
1601 /* If the loop is empty, go directly to the exit label. */
1602 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1603 build1_v (GOTO_EXPR, exit_label),
1604 build_empty_stmt (input_location));
1605 gfc_add_expr_to_block (&block, tmp);
1609 gfc_start_block (&body);
1611 /* Main loop body. */
1612 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1613 gfc_add_expr_to_block (&body, tmp);
1615 /* Label for cycle statements (if needed). */
1616 if (TREE_USED (cycle_label))
1618 tmp = build1_v (LABEL_EXPR, cycle_label);
1619 gfc_add_expr_to_block (&body, tmp);
1622 /* Check whether someone has modified the loop variable. */
1623 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1625 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
1627 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1628 "Loop variable has been modified");
1631 /* Exit the loop if there is an I/O result condition or error. */
1634 tmp = build1_v (GOTO_EXPR, exit_label);
1635 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1637 build_empty_stmt (input_location));
1638 gfc_add_expr_to_block (&body, tmp);
1641 /* Increment the loop variable. */
1642 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1643 gfc_add_modify_loc (loc, &body, dovar, tmp);
1645 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1646 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1648 /* End with the loop condition. Loop until countm1 == 0. */
1649 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1,
1650 build_int_cst (utype, 0));
1651 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1652 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1653 cond, tmp, build_empty_stmt (loc));
1654 gfc_add_expr_to_block (&body, tmp);
1656 /* Decrement the loop count. */
1657 tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
1658 build_int_cst (utype, 1));
1659 gfc_add_modify_loc (loc, &body, countm1, tmp);
1661 /* End of loop body. */
1662 tmp = gfc_finish_block (&body);
1664 /* The for loop itself. */
1665 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1666 gfc_add_expr_to_block (&block, tmp);
1668 /* Add the exit label. */
1669 tmp = build1_v (LABEL_EXPR, exit_label);
1670 gfc_add_expr_to_block (&block, tmp);
1672 return gfc_finish_block (&block);
1676 /* Translate the DO WHILE construct.
1689 if (! cond) goto exit_label;
1695 Because the evaluation of the exit condition `cond' may have side
1696 effects, we can't do much for empty loop bodies. The backend optimizers
1697 should be smart enough to eliminate any dead loops. */
1700 gfc_trans_do_while (gfc_code * code)
1708 /* Everything we build here is part of the loop body. */
1709 gfc_start_block (&block);
1711 /* Cycle and exit statements are implemented with gotos. */
1712 cycle_label = gfc_build_label_decl (NULL_TREE);
1713 exit_label = gfc_build_label_decl (NULL_TREE);
1715 /* Put the labels where they can be found later. See gfc_trans_do(). */
1716 code->cycle_label = cycle_label;
1717 code->exit_label = exit_label;
1719 /* Create a GIMPLE version of the exit condition. */
1720 gfc_init_se (&cond, NULL);
1721 gfc_conv_expr_val (&cond, code->expr1);
1722 gfc_add_block_to_block (&block, &cond.pre);
1723 cond.expr = fold_build1_loc (code->expr1->where.lb->location,
1724 TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
1726 /* Build "IF (! cond) GOTO exit_label". */
1727 tmp = build1_v (GOTO_EXPR, exit_label);
1728 TREE_USED (exit_label) = 1;
1729 tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
1730 void_type_node, cond.expr, tmp,
1731 build_empty_stmt (code->expr1->where.lb->location));
1732 gfc_add_expr_to_block (&block, tmp);
1734 /* The main body of the loop. */
1735 tmp = gfc_trans_code (code->block->next);
1736 gfc_add_expr_to_block (&block, tmp);
1738 /* Label for cycle statements (if needed). */
1739 if (TREE_USED (cycle_label))
1741 tmp = build1_v (LABEL_EXPR, cycle_label);
1742 gfc_add_expr_to_block (&block, tmp);
1745 /* End of loop body. */
1746 tmp = gfc_finish_block (&block);
1748 gfc_init_block (&block);
1749 /* Build the loop. */
1750 tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
1751 void_type_node, tmp);
1752 gfc_add_expr_to_block (&block, tmp);
1754 /* Add the exit label. */
1755 tmp = build1_v (LABEL_EXPR, exit_label);
1756 gfc_add_expr_to_block (&block, tmp);
1758 return gfc_finish_block (&block);
1762 /* Translate the SELECT CASE construct for INTEGER case expressions,
1763 without killing all potential optimizations. The problem is that
1764 Fortran allows unbounded cases, but the back-end does not, so we
1765 need to intercept those before we enter the equivalent SWITCH_EXPR
1768 For example, we translate this,
1771 CASE (:100,101,105:115)
1781 to the GENERIC equivalent,
1785 case (minimum value for typeof(expr) ... 100:
1791 case 200 ... (maximum value for typeof(expr):
1808 gfc_trans_integer_select (gfc_code * code)
1818 gfc_start_block (&block);
1820 /* Calculate the switch expression. */
1821 gfc_init_se (&se, NULL);
1822 gfc_conv_expr_val (&se, code->expr1);
1823 gfc_add_block_to_block (&block, &se.pre);
1825 end_label = gfc_build_label_decl (NULL_TREE);
1827 gfc_init_block (&body);
1829 for (c = code->block; c; c = c->block)
1831 for (cp = c->ext.block.case_list; cp; cp = cp->next)
1836 /* Assume it's the default case. */
1837 low = high = NULL_TREE;
1841 low = gfc_conv_mpz_to_tree (cp->low->value.integer,
1844 /* If there's only a lower bound, set the high bound to the
1845 maximum value of the case expression. */
1847 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1852 /* Three cases are possible here:
1854 1) There is no lower bound, e.g. CASE (:N).
1855 2) There is a lower bound .NE. high bound, that is
1856 a case range, e.g. CASE (N:M) where M>N (we make
1857 sure that M>N during type resolution).
1858 3) There is a lower bound, and it has the same value
1859 as the high bound, e.g. CASE (N:N). This is our
1860 internal representation of CASE(N).
1862 In the first and second case, we need to set a value for
1863 high. In the third case, we don't because the GCC middle
1864 end represents a single case value by just letting high be
1865 a NULL_TREE. We can't do that because we need to be able
1866 to represent unbounded cases. */
1870 && mpz_cmp (cp->low->value.integer,
1871 cp->high->value.integer) != 0))
1872 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
1875 /* Unbounded case. */
1877 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1880 /* Build a label. */
1881 label = gfc_build_label_decl (NULL_TREE);
1883 /* Add this case label.
1884 Add parameter 'label', make it match GCC backend. */
1885 tmp = build_case_label (low, high, label);
1886 gfc_add_expr_to_block (&body, tmp);
1889 /* Add the statements for this case. */
1890 tmp = gfc_trans_code (c->next);
1891 gfc_add_expr_to_block (&body, tmp);
1893 /* Break to the end of the construct. */
1894 tmp = build1_v (GOTO_EXPR, end_label);
1895 gfc_add_expr_to_block (&body, tmp);
1898 tmp = gfc_finish_block (&body);
1899 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1900 gfc_add_expr_to_block (&block, tmp);
1902 tmp = build1_v (LABEL_EXPR, end_label);
1903 gfc_add_expr_to_block (&block, tmp);
1905 return gfc_finish_block (&block);
1909 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1911 There are only two cases possible here, even though the standard
1912 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1913 .FALSE., and DEFAULT.
1915 We never generate more than two blocks here. Instead, we always
1916 try to eliminate the DEFAULT case. This way, we can translate this
1917 kind of SELECT construct to a simple
1921 expression in GENERIC. */
1924 gfc_trans_logical_select (gfc_code * code)
1927 gfc_code *t, *f, *d;
1932 /* Assume we don't have any cases at all. */
1935 /* Now see which ones we actually do have. We can have at most two
1936 cases in a single case list: one for .TRUE. and one for .FALSE.
1937 The default case is always separate. If the cases for .TRUE. and
1938 .FALSE. are in the same case list, the block for that case list
1939 always executed, and we don't generate code a COND_EXPR. */
1940 for (c = code->block; c; c = c->block)
1942 for (cp = c->ext.block.case_list; cp; cp = cp->next)
1946 if (cp->low->value.logical == 0) /* .FALSE. */
1948 else /* if (cp->value.logical != 0), thus .TRUE. */
1956 /* Start a new block. */
1957 gfc_start_block (&block);
1959 /* Calculate the switch expression. We always need to do this
1960 because it may have side effects. */
1961 gfc_init_se (&se, NULL);
1962 gfc_conv_expr_val (&se, code->expr1);
1963 gfc_add_block_to_block (&block, &se.pre);
1965 if (t == f && t != NULL)
1967 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1968 translate the code for these cases, append it to the current
1970 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1974 tree true_tree, false_tree, stmt;
1976 true_tree = build_empty_stmt (input_location);
1977 false_tree = build_empty_stmt (input_location);
1979 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1980 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1981 make the missing case the default case. */
1982 if (t != NULL && f != NULL)
1992 /* Translate the code for each of these blocks, and append it to
1993 the current block. */
1995 true_tree = gfc_trans_code (t->next);
1998 false_tree = gfc_trans_code (f->next);
2000 stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2001 se.expr, true_tree, false_tree);
2002 gfc_add_expr_to_block (&block, stmt);
2005 return gfc_finish_block (&block);
2009 /* The jump table types are stored in static variables to avoid
2010 constructing them from scratch every single time. */
2011 static GTY(()) tree select_struct[2];
2013 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2014 Instead of generating compares and jumps, it is far simpler to
2015 generate a data structure describing the cases in order and call a
2016 library subroutine that locates the right case.
2017 This is particularly true because this is the only case where we
2018 might have to dispose of a temporary.
2019 The library subroutine returns a pointer to jump to or NULL if no
2020 branches are to be taken. */
2023 gfc_trans_character_select (gfc_code *code)
2025 tree init, end_label, tmp, type, case_num, label, fndecl;
2026 stmtblock_t block, body;
2031 VEC(constructor_elt,gc) *inits = NULL;
2033 tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
2035 /* The jump table types are stored in static variables to avoid
2036 constructing them from scratch every single time. */
2037 static tree ss_string1[2], ss_string1_len[2];
2038 static tree ss_string2[2], ss_string2_len[2];
2039 static tree ss_target[2];
2041 cp = code->block->ext.block.case_list;
2042 while (cp->left != NULL)
2045 /* Generate the body */
2046 gfc_start_block (&block);
2047 gfc_init_se (&expr1se, NULL);
2048 gfc_conv_expr_reference (&expr1se, code->expr1);
2050 gfc_add_block_to_block (&block, &expr1se.pre);
2052 end_label = gfc_build_label_decl (NULL_TREE);
2054 gfc_init_block (&body);
2056 /* Attempt to optimize length 1 selects. */
2057 if (integer_onep (expr1se.string_length))
2059 for (d = cp; d; d = d->right)
2064 gcc_assert (d->low->expr_type == EXPR_CONSTANT
2065 && d->low->ts.type == BT_CHARACTER);
2066 if (d->low->value.character.length > 1)
2068 for (i = 1; i < d->low->value.character.length; i++)
2069 if (d->low->value.character.string[i] != ' ')
2071 if (i != d->low->value.character.length)
2073 if (optimize && d->high && i == 1)
2075 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2076 && d->high->ts.type == BT_CHARACTER);
2077 if (d->high->value.character.length > 1
2078 && (d->low->value.character.string[0]
2079 == d->high->value.character.string[0])
2080 && d->high->value.character.string[1] != ' '
2081 && ((d->low->value.character.string[1] < ' ')
2082 == (d->high->value.character.string[1]
2092 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2093 && d->high->ts.type == BT_CHARACTER);
2094 if (d->high->value.character.length > 1)
2096 for (i = 1; i < d->high->value.character.length; i++)
2097 if (d->high->value.character.string[i] != ' ')
2099 if (i != d->high->value.character.length)
2106 tree ctype = gfc_get_char_type (code->expr1->ts.kind);
2108 for (c = code->block; c; c = c->block)
2110 for (cp = c->ext.block.case_list; cp; cp = cp->next)
2116 /* Assume it's the default case. */
2117 low = high = NULL_TREE;
2121 /* CASE ('ab') or CASE ('ab':'az') will never match
2122 any length 1 character. */
2123 if (cp->low->value.character.length > 1
2124 && cp->low->value.character.string[1] != ' ')
2127 if (cp->low->value.character.length > 0)
2128 r = cp->low->value.character.string[0];
2131 low = build_int_cst (ctype, r);
2133 /* If there's only a lower bound, set the high bound
2134 to the maximum value of the case expression. */
2136 high = TYPE_MAX_VALUE (ctype);
2142 || (cp->low->value.character.string[0]
2143 != cp->high->value.character.string[0]))
2145 if (cp->high->value.character.length > 0)
2146 r = cp->high->value.character.string[0];
2149 high = build_int_cst (ctype, r);
2152 /* Unbounded case. */
2154 low = TYPE_MIN_VALUE (ctype);
2157 /* Build a label. */
2158 label = gfc_build_label_decl (NULL_TREE);
2160 /* Add this case label.
2161 Add parameter 'label', make it match GCC backend. */
2162 tmp = build_case_label (low, high, label);
2163 gfc_add_expr_to_block (&body, tmp);
2166 /* Add the statements for this case. */
2167 tmp = gfc_trans_code (c->next);
2168 gfc_add_expr_to_block (&body, tmp);
2170 /* Break to the end of the construct. */
2171 tmp = build1_v (GOTO_EXPR, end_label);
2172 gfc_add_expr_to_block (&body, tmp);
2175 tmp = gfc_string_to_single_character (expr1se.string_length,
2177 code->expr1->ts.kind);
2178 case_num = gfc_create_var (ctype, "case_num");
2179 gfc_add_modify (&block, case_num, tmp);
2181 gfc_add_block_to_block (&block, &expr1se.post);
2183 tmp = gfc_finish_block (&body);
2184 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2185 gfc_add_expr_to_block (&block, tmp);
2187 tmp = build1_v (LABEL_EXPR, end_label);
2188 gfc_add_expr_to_block (&block, tmp);
2190 return gfc_finish_block (&block);
2194 if (code->expr1->ts.kind == 1)
2196 else if (code->expr1->ts.kind == 4)
2201 if (select_struct[k] == NULL)
2204 select_struct[k] = make_node (RECORD_TYPE);
2206 if (code->expr1->ts.kind == 1)
2207 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
2208 else if (code->expr1->ts.kind == 4)
2209 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
2214 #define ADD_FIELD(NAME, TYPE) \
2215 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2216 get_identifier (stringize(NAME)), \
2220 ADD_FIELD (string1, pchartype);
2221 ADD_FIELD (string1_len, gfc_charlen_type_node);
2223 ADD_FIELD (string2, pchartype);
2224 ADD_FIELD (string2_len, gfc_charlen_type_node);
2226 ADD_FIELD (target, integer_type_node);
2229 gfc_finish_type (select_struct[k]);
2233 for (d = cp; d; d = d->right)
2236 for (c = code->block; c; c = c->block)
2238 for (d = c->ext.block.case_list; d; d = d->next)
2240 label = gfc_build_label_decl (NULL_TREE);
2241 tmp = build_case_label ((d->low == NULL && d->high == NULL)
2243 : build_int_cst (integer_type_node, d->n),
2245 gfc_add_expr_to_block (&body, tmp);
2248 tmp = gfc_trans_code (c->next);
2249 gfc_add_expr_to_block (&body, tmp);
2251 tmp = build1_v (GOTO_EXPR, end_label);
2252 gfc_add_expr_to_block (&body, tmp);
2255 /* Generate the structure describing the branches */
2256 for (d = cp; d; d = d->right)
2258 VEC(constructor_elt,gc) *node = NULL;
2260 gfc_init_se (&se, NULL);
2264 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
2265 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
2269 gfc_conv_expr_reference (&se, d->low);
2271 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
2272 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
2275 if (d->high == NULL)
2277 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
2278 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
2282 gfc_init_se (&se, NULL);
2283 gfc_conv_expr_reference (&se, d->high);
2285 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
2286 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
2289 CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
2290 build_int_cst (integer_type_node, d->n));
2292 tmp = build_constructor (select_struct[k], node);
2293 CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
2296 type = build_array_type (select_struct[k],
2297 build_index_type (size_int (n-1)));
2299 init = build_constructor (type, inits);
2300 TREE_CONSTANT (init) = 1;
2301 TREE_STATIC (init) = 1;
2302 /* Create a static variable to hold the jump table. */
2303 tmp = gfc_create_var (type, "jumptable");
2304 TREE_CONSTANT (tmp) = 1;
2305 TREE_STATIC (tmp) = 1;
2306 TREE_READONLY (tmp) = 1;
2307 DECL_INITIAL (tmp) = init;
2310 /* Build the library call */
2311 init = gfc_build_addr_expr (pvoid_type_node, init);
2313 if (code->expr1->ts.kind == 1)
2314 fndecl = gfor_fndecl_select_string;
2315 else if (code->expr1->ts.kind == 4)
2316 fndecl = gfor_fndecl_select_string_char4;
2320 tmp = build_call_expr_loc (input_location,
2322 build_int_cst (gfc_charlen_type_node, n),
2323 expr1se.expr, expr1se.string_length);
2324 case_num = gfc_create_var (integer_type_node, "case_num");
2325 gfc_add_modify (&block, case_num, tmp);
2327 gfc_add_block_to_block (&block, &expr1se.post);
2329 tmp = gfc_finish_block (&body);
2330 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2331 gfc_add_expr_to_block (&block, tmp);
2333 tmp = build1_v (LABEL_EXPR, end_label);
2334 gfc_add_expr_to_block (&block, tmp);
2336 return gfc_finish_block (&block);
2340 /* Translate the three variants of the SELECT CASE construct.
2342 SELECT CASEs with INTEGER case expressions can be translated to an
2343 equivalent GENERIC switch statement, and for LOGICAL case
2344 expressions we build one or two if-else compares.
2346 SELECT CASEs with CHARACTER case expressions are a whole different
2347 story, because they don't exist in GENERIC. So we sort them and
2348 do a binary search at runtime.
2350 Fortran has no BREAK statement, and it does not allow jumps from
2351 one case block to another. That makes things a lot easier for
2355 gfc_trans_select (gfc_code * code)
2361 gcc_assert (code && code->expr1);
2362 gfc_init_block (&block);
2364 /* Build the exit label and hang it in. */
2365 exit_label = gfc_build_label_decl (NULL_TREE);
2366 code->exit_label = exit_label;
2368 /* Empty SELECT constructs are legal. */
2369 if (code->block == NULL)
2370 body = build_empty_stmt (input_location);
2372 /* Select the correct translation function. */
2374 switch (code->expr1->ts.type)
2377 body = gfc_trans_logical_select (code);
2381 body = gfc_trans_integer_select (code);
2385 body = gfc_trans_character_select (code);
2389 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2393 /* Build everything together. */
2394 gfc_add_expr_to_block (&block, body);
2395 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
2397 return gfc_finish_block (&block);
2401 /* Traversal function to substitute a replacement symtree if the symbol
2402 in the expression is the same as that passed. f == 2 signals that
2403 that variable itself is not to be checked - only the references.
2404 This group of functions is used when the variable expression in a
2405 FORALL assignment has internal references. For example:
2406 FORALL (i = 1:4) p(p(i)) = i
2407 The only recourse here is to store a copy of 'p' for the index
2410 static gfc_symtree *new_symtree;
2411 static gfc_symtree *old_symtree;
2414 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
2416 if (expr->expr_type != EXPR_VARIABLE)
2421 else if (expr->symtree->n.sym == sym)
2422 expr->symtree = new_symtree;
2428 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
2430 gfc_traverse_expr (e, sym, forall_replace, f);
2434 forall_restore (gfc_expr *expr,
2435 gfc_symbol *sym ATTRIBUTE_UNUSED,
2436 int *f ATTRIBUTE_UNUSED)
2438 if (expr->expr_type != EXPR_VARIABLE)
2441 if (expr->symtree == new_symtree)
2442 expr->symtree = old_symtree;
2448 forall_restore_symtree (gfc_expr *e)
2450 gfc_traverse_expr (e, NULL, forall_restore, 0);
2454 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2459 gfc_symbol *new_sym;
2460 gfc_symbol *old_sym;
2464 /* Build a copy of the lvalue. */
2465 old_symtree = c->expr1->symtree;
2466 old_sym = old_symtree->n.sym;
2467 e = gfc_lval_expr_from_sym (old_sym);
2468 if (old_sym->attr.dimension)
2470 gfc_init_se (&tse, NULL);
2471 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
2472 gfc_add_block_to_block (pre, &tse.pre);
2473 gfc_add_block_to_block (post, &tse.post);
2474 tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
2476 if (e->ts.type != BT_CHARACTER)
2478 /* Use the variable offset for the temporary. */
2479 tmp = gfc_conv_array_offset (old_sym->backend_decl);
2480 gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
2485 gfc_init_se (&tse, NULL);
2486 gfc_init_se (&rse, NULL);
2487 gfc_conv_expr (&rse, e);
2488 if (e->ts.type == BT_CHARACTER)
2490 tse.string_length = rse.string_length;
2491 tmp = gfc_get_character_type_len (gfc_default_character_kind,
2493 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
2495 gfc_add_block_to_block (pre, &tse.pre);
2496 gfc_add_block_to_block (post, &tse.post);
2500 tmp = gfc_typenode_for_spec (&e->ts);
2501 tse.expr = gfc_create_var (tmp, "temp");
2504 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
2505 e->expr_type == EXPR_VARIABLE, true);
2506 gfc_add_expr_to_block (pre, tmp);
2510 /* Create a new symbol to represent the lvalue. */
2511 new_sym = gfc_new_symbol (old_sym->name, NULL);
2512 new_sym->ts = old_sym->ts;
2513 new_sym->attr.referenced = 1;
2514 new_sym->attr.temporary = 1;
2515 new_sym->attr.dimension = old_sym->attr.dimension;
2516 new_sym->attr.flavor = old_sym->attr.flavor;
2518 /* Use the temporary as the backend_decl. */
2519 new_sym->backend_decl = tse.expr;
2521 /* Create a fake symtree for it. */
2523 new_symtree = gfc_new_symtree (&root, old_sym->name);
2524 new_symtree->n.sym = new_sym;
2525 gcc_assert (new_symtree == root);
2527 /* Go through the expression reference replacing the old_symtree
2529 forall_replace_symtree (c->expr1, old_sym, 2);
2531 /* Now we have made this temporary, we might as well use it for
2532 the right hand side. */
2533 forall_replace_symtree (c->expr2, old_sym, 1);
2537 /* Handles dependencies in forall assignments. */
2539 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2546 lsym = c->expr1->symtree->n.sym;
2547 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
2549 /* Now check for dependencies within the 'variable'
2550 expression itself. These are treated by making a complete
2551 copy of variable and changing all the references to it
2552 point to the copy instead. Note that the shallow copy of
2553 the variable will not suffice for derived types with
2554 pointer components. We therefore leave these to their
2556 if (lsym->ts.type == BT_DERIVED
2557 && lsym->ts.u.derived->attr.pointer_comp)
2561 if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
2563 forall_make_variable_temp (c, pre, post);
2567 /* Substrings with dependencies are treated in the same
2569 if (c->expr1->ts.type == BT_CHARACTER
2571 && c->expr2->expr_type == EXPR_VARIABLE
2572 && lsym == c->expr2->symtree->n.sym)
2574 for (lref = c->expr1->ref; lref; lref = lref->next)
2575 if (lref->type == REF_SUBSTRING)
2577 for (rref = c->expr2->ref; rref; rref = rref->next)
2578 if (rref->type == REF_SUBSTRING)
2582 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
2584 forall_make_variable_temp (c, pre, post);
2593 cleanup_forall_symtrees (gfc_code *c)
2595 forall_restore_symtree (c->expr1);
2596 forall_restore_symtree (c->expr2);
2597 free (new_symtree->n.sym);
2602 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
2603 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
2604 indicates whether we should generate code to test the FORALLs mask
2605 array. OUTER is the loop header to be used for initializing mask
2608 The generated loop format is:
2609 count = (end - start + step) / step
2622 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
2623 int mask_flag, stmtblock_t *outer)
2631 tree var, start, end, step;
2634 /* Initialize the mask index outside the FORALL nest. */
2635 if (mask_flag && forall_tmp->mask)
2636 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
2638 iter = forall_tmp->this_loop;
2639 nvar = forall_tmp->nvar;
2640 for (n = 0; n < nvar; n++)
2643 start = iter->start;
2647 exit_label = gfc_build_label_decl (NULL_TREE);
2648 TREE_USED (exit_label) = 1;
2650 /* The loop counter. */
2651 count = gfc_create_var (TREE_TYPE (var), "count");
2653 /* The body of the loop. */
2654 gfc_init_block (&block);
2656 /* The exit condition. */
2657 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
2658 count, build_int_cst (TREE_TYPE (count), 0));
2659 tmp = build1_v (GOTO_EXPR, exit_label);
2660 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2661 cond, tmp, build_empty_stmt (input_location));
2662 gfc_add_expr_to_block (&block, tmp);
2664 /* The main loop body. */
2665 gfc_add_expr_to_block (&block, body);
2667 /* Increment the loop variable. */
2668 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
2670 gfc_add_modify (&block, var, tmp);
2672 /* Advance to the next mask element. Only do this for the
2674 if (n == 0 && mask_flag && forall_tmp->mask)
2676 tree maskindex = forall_tmp->maskindex;
2677 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2678 maskindex, gfc_index_one_node);
2679 gfc_add_modify (&block, maskindex, tmp);
2682 /* Decrement the loop counter. */
2683 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
2684 build_int_cst (TREE_TYPE (var), 1));
2685 gfc_add_modify (&block, count, tmp);
2687 body = gfc_finish_block (&block);
2689 /* Loop var initialization. */
2690 gfc_init_block (&block);
2691 gfc_add_modify (&block, var, start);
2694 /* Initialize the loop counter. */
2695 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
2697 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
2699 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
2701 gfc_add_modify (&block, count, tmp);
2703 /* The loop expression. */
2704 tmp = build1_v (LOOP_EXPR, body);
2705 gfc_add_expr_to_block (&block, tmp);
2707 /* The exit label. */
2708 tmp = build1_v (LABEL_EXPR, exit_label);
2709 gfc_add_expr_to_block (&block, tmp);
2711 body = gfc_finish_block (&block);
2718 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
2719 is nonzero, the body is controlled by all masks in the forall nest.
2720 Otherwise, the innermost loop is not controlled by it's mask. This
2721 is used for initializing that mask. */
2724 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
2729 forall_info *forall_tmp;
2730 tree mask, maskindex;
2732 gfc_start_block (&header);
2734 forall_tmp = nested_forall_info;
2735 while (forall_tmp != NULL)
2737 /* Generate body with masks' control. */
2740 mask = forall_tmp->mask;
2741 maskindex = forall_tmp->maskindex;
2743 /* If a mask was specified make the assignment conditional. */
2746 tmp = gfc_build_array_ref (mask, maskindex, NULL);
2747 body = build3_v (COND_EXPR, tmp, body,
2748 build_empty_stmt (input_location));
2751 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
2752 forall_tmp = forall_tmp->prev_nest;
2756 gfc_add_expr_to_block (&header, body);
2757 return gfc_finish_block (&header);
2761 /* Allocate data for holding a temporary array. Returns either a local
2762 temporary array or a pointer variable. */
2765 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
2772 if (INTEGER_CST_P (size))
2773 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2774 size, gfc_index_one_node);
2778 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
2779 type = build_array_type (elem_type, type);
2780 if (gfc_can_put_var_on_stack (bytesize))
2782 gcc_assert (INTEGER_CST_P (size));
2783 tmpvar = gfc_create_var (type, "temp");
2788 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
2789 *pdata = convert (pvoid_type_node, tmpvar);
2791 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
2792 gfc_add_modify (pblock, tmpvar, tmp);
2798 /* Generate codes to copy the temporary to the actual lhs. */
2801 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
2802 tree count1, tree wheremask, bool invert)
2806 stmtblock_t block, body;
2812 lss = gfc_walk_expr (expr);
2814 if (lss == gfc_ss_terminator)
2816 gfc_start_block (&block);
2818 gfc_init_se (&lse, NULL);
2820 /* Translate the expression. */
2821 gfc_conv_expr (&lse, expr);
2823 /* Form the expression for the temporary. */
2824 tmp = gfc_build_array_ref (tmp1, count1, NULL);
2826 /* Use the scalar assignment as is. */
2827 gfc_add_block_to_block (&block, &lse.pre);
2828 gfc_add_modify (&block, lse.expr, tmp);
2829 gfc_add_block_to_block (&block, &lse.post);
2831 /* Increment the count1. */
2832 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2833 count1, gfc_index_one_node);
2834 gfc_add_modify (&block, count1, tmp);
2836 tmp = gfc_finish_block (&block);
2840 gfc_start_block (&block);
2842 gfc_init_loopinfo (&loop1);
2843 gfc_init_se (&rse, NULL);
2844 gfc_init_se (&lse, NULL);
2846 /* Associate the lss with the loop. */
2847 gfc_add_ss_to_loop (&loop1, lss);
2849 /* Calculate the bounds of the scalarization. */
2850 gfc_conv_ss_startstride (&loop1);
2851 /* Setup the scalarizing loops. */
2852 gfc_conv_loop_setup (&loop1, &expr->where);
2854 gfc_mark_ss_chain_used (lss, 1);
2856 /* Start the scalarized loop body. */
2857 gfc_start_scalarized_body (&loop1, &body);
2859 /* Setup the gfc_se structures. */
2860 gfc_copy_loopinfo_to_se (&lse, &loop1);
2863 /* Form the expression of the temporary. */
2864 if (lss != gfc_ss_terminator)
2865 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2866 /* Translate expr. */
2867 gfc_conv_expr (&lse, expr);
2869 /* Use the scalar assignment. */
2870 rse.string_length = lse.string_length;
2871 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
2873 /* Form the mask expression according to the mask tree list. */
2876 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2878 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2879 TREE_TYPE (wheremaskexpr),
2881 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2883 build_empty_stmt (input_location));
2886 gfc_add_expr_to_block (&body, tmp);
2888 /* Increment count1. */
2889 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2890 count1, gfc_index_one_node);
2891 gfc_add_modify (&body, count1, tmp);
2893 /* Increment count3. */
2896 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2897 gfc_array_index_type, count3,
2898 gfc_index_one_node);
2899 gfc_add_modify (&body, count3, tmp);
2902 /* Generate the copying loops. */
2903 gfc_trans_scalarizing_loops (&loop1, &body);
2904 gfc_add_block_to_block (&block, &loop1.pre);
2905 gfc_add_block_to_block (&block, &loop1.post);
2906 gfc_cleanup_loop (&loop1);
2908 tmp = gfc_finish_block (&block);
2914 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
2915 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
2916 and should not be freed. WHEREMASK is the conditional execution mask
2917 whose sense may be inverted by INVERT. */
2920 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
2921 tree count1, gfc_ss *lss, gfc_ss *rss,
2922 tree wheremask, bool invert)
2924 stmtblock_t block, body1;
2931 gfc_start_block (&block);
2933 gfc_init_se (&rse, NULL);
2934 gfc_init_se (&lse, NULL);
2936 if (lss == gfc_ss_terminator)
2938 gfc_init_block (&body1);
2939 gfc_conv_expr (&rse, expr2);
2940 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2944 /* Initialize the loop. */
2945 gfc_init_loopinfo (&loop);
2947 /* We may need LSS to determine the shape of the expression. */
2948 gfc_add_ss_to_loop (&loop, lss);
2949 gfc_add_ss_to_loop (&loop, rss);
2951 gfc_conv_ss_startstride (&loop);
2952 gfc_conv_loop_setup (&loop, &expr2->where);
2954 gfc_mark_ss_chain_used (rss, 1);
2955 /* Start the loop body. */
2956 gfc_start_scalarized_body (&loop, &body1);
2958 /* Translate the expression. */
2959 gfc_copy_loopinfo_to_se (&rse, &loop);
2961 gfc_conv_expr (&rse, expr2);
2963 /* Form the expression of the temporary. */
2964 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2967 /* Use the scalar assignment. */
2968 lse.string_length = rse.string_length;
2969 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
2970 expr2->expr_type == EXPR_VARIABLE, true);
2972 /* Form the mask expression according to the mask tree list. */
2975 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2977 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2978 TREE_TYPE (wheremaskexpr),
2980 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2982 build_empty_stmt (input_location));
2985 gfc_add_expr_to_block (&body1, tmp);
2987 if (lss == gfc_ss_terminator)
2989 gfc_add_block_to_block (&block, &body1);
2991 /* Increment count1. */
2992 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2993 count1, gfc_index_one_node);
2994 gfc_add_modify (&block, count1, tmp);
2998 /* Increment count1. */
2999 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3000 count1, gfc_index_one_node);
3001 gfc_add_modify (&body1, count1, tmp);
3003 /* Increment count3. */
3006 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3007 gfc_array_index_type,
3008 count3, gfc_index_one_node);
3009 gfc_add_modify (&body1, count3, tmp);
3012 /* Generate the copying loops. */
3013 gfc_trans_scalarizing_loops (&loop, &body1);
3015 gfc_add_block_to_block (&block, &loop.pre);
3016 gfc_add_block_to_block (&block, &loop.post);
3018 gfc_cleanup_loop (&loop);
3019 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3020 as tree nodes in SS may not be valid in different scope. */
3023 tmp = gfc_finish_block (&block);
3028 /* Calculate the size of temporary needed in the assignment inside forall.
3029 LSS and RSS are filled in this function. */
3032 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
3033 stmtblock_t * pblock,
3034 gfc_ss **lss, gfc_ss **rss)
3042 *lss = gfc_walk_expr (expr1);
3045 size = gfc_index_one_node;
3046 if (*lss != gfc_ss_terminator)
3048 gfc_init_loopinfo (&loop);
3050 /* Walk the RHS of the expression. */
3051 *rss = gfc_walk_expr (expr2);
3052 if (*rss == gfc_ss_terminator)
3053 /* The rhs is scalar. Add a ss for the expression. */
3054 *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
3056 /* Associate the SS with the loop. */
3057 gfc_add_ss_to_loop (&loop, *lss);
3058 /* We don't actually need to add the rhs at this point, but it might
3059 make guessing the loop bounds a bit easier. */
3060 gfc_add_ss_to_loop (&loop, *rss);
3062 /* We only want the shape of the expression, not rest of the junk
3063 generated by the scalarizer. */
3064 loop.array_parameter = 1;
3066 /* Calculate the bounds of the scalarization. */
3067 save_flag = gfc_option.rtcheck;
3068 gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
3069 gfc_conv_ss_startstride (&loop);
3070 gfc_option.rtcheck = save_flag;
3071 gfc_conv_loop_setup (&loop, &expr2->where);
3073 /* Figure out how many elements we need. */
3074 for (i = 0; i < loop.dimen; i++)
3076 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3077 gfc_array_index_type,
3078 gfc_index_one_node, loop.from[i]);
3079 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3080 gfc_array_index_type, tmp, loop.to[i]);
3081 size = fold_build2_loc (input_location, MULT_EXPR,
3082 gfc_array_index_type, size, tmp);
3084 gfc_add_block_to_block (pblock, &loop.pre);
3085 size = gfc_evaluate_now (size, pblock);
3086 gfc_add_block_to_block (pblock, &loop.post);
3088 /* TODO: write a function that cleans up a loopinfo without freeing
3089 the SS chains. Currently a NOP. */
3096 /* Calculate the overall iterator number of the nested forall construct.
3097 This routine actually calculates the number of times the body of the
3098 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3099 that by the expression INNER_SIZE. The BLOCK argument specifies the
3100 block in which to calculate the result, and the optional INNER_SIZE_BODY
3101 argument contains any statements that need to executed (inside the loop)
3102 to initialize or calculate INNER_SIZE. */
3105 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
3106 stmtblock_t *inner_size_body, stmtblock_t *block)
3108 forall_info *forall_tmp = nested_forall_info;
3112 /* We can eliminate the innermost unconditional loops with constant
3114 if (INTEGER_CST_P (inner_size))
3117 && !forall_tmp->mask
3118 && INTEGER_CST_P (forall_tmp->size))
3120 inner_size = fold_build2_loc (input_location, MULT_EXPR,
3121 gfc_array_index_type,
3122 inner_size, forall_tmp->size);
3123 forall_tmp = forall_tmp->prev_nest;
3126 /* If there are no loops left, we have our constant result. */
3131 /* Otherwise, create a temporary variable to compute the result. */
3132 number = gfc_create_var (gfc_array_index_type, "num");
3133 gfc_add_modify (block, number, gfc_index_zero_node);
3135 gfc_start_block (&body);
3136 if (inner_size_body)
3137 gfc_add_block_to_block (&body, inner_size_body);
3139 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3140 gfc_array_index_type, number, inner_size);
3143 gfc_add_modify (&body, number, tmp);
3144 tmp = gfc_finish_block (&body);
3146 /* Generate loops. */
3147 if (forall_tmp != NULL)
3148 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
3150 gfc_add_expr_to_block (block, tmp);
3156 /* Allocate temporary for forall construct. SIZE is the size of temporary
3157 needed. PTEMP1 is returned for space free. */
3160 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
3167 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
3168 if (!integer_onep (unit))
3169 bytesize = fold_build2_loc (input_location, MULT_EXPR,
3170 gfc_array_index_type, size, unit);
3175 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
3178 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3183 /* Allocate temporary for forall construct according to the information in
3184 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3185 assignment inside forall. PTEMP1 is returned for space free. */
3188 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
3189 tree inner_size, stmtblock_t * inner_size_body,
3190 stmtblock_t * block, tree * ptemp1)
3194 /* Calculate the total size of temporary needed in forall construct. */
3195 size = compute_overall_iter_number (nested_forall_info, inner_size,
3196 inner_size_body, block);
3198 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
3202 /* Handle assignments inside forall which need temporary.
3204 forall (i=start:end:stride; maskexpr)
3207 (where e,f<i> are arbitrary expressions possibly involving i
3208 and there is a dependency between e<i> and f<i>)
3210 masktmp(:) = maskexpr(:)
3215 for (i = start; i <= end; i += stride)
3219 for (i = start; i <= end; i += stride)
3221 if (masktmp[maskindex++])
3222 tmp[count1++] = f<i>
3226 for (i = start; i <= end; i += stride)
3228 if (masktmp[maskindex++])
3229 e<i> = tmp[count1++]
3234 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3235 tree wheremask, bool invert,
3236 forall_info * nested_forall_info,
3237 stmtblock_t * block)
3245 stmtblock_t inner_size_body;
3247 /* Create vars. count1 is the current iterator number of the nested
3249 count1 = gfc_create_var (gfc_array_index_type, "count1");
3251 /* Count is the wheremask index. */
3254 count = gfc_create_var (gfc_array_index_type, "count");
3255 gfc_add_modify (block, count, gfc_index_zero_node);
3260 /* Initialize count1. */
3261 gfc_add_modify (block, count1, gfc_index_zero_node);
3263 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3264 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3265 gfc_init_block (&inner_size_body);
3266 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
3269 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3270 if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
3272 if (!expr1->ts.u.cl->backend_decl)
3275 gfc_init_se (&tse, NULL);
3276 gfc_conv_expr (&tse, expr1->ts.u.cl->length);
3277 expr1->ts.u.cl->backend_decl = tse.expr;
3279 type = gfc_get_character_type_len (gfc_default_character_kind,
3280 expr1->ts.u.cl->backend_decl);
3283 type = gfc_typenode_for_spec (&expr1->ts);
3285 /* Allocate temporary for nested forall construct according to the
3286 information in nested_forall_info and inner_size. */
3287 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
3288 &inner_size_body, block, &ptemp1);
3290 /* Generate codes to copy rhs to the temporary . */
3291 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
3294 /* Generate body and loops according to the information in
3295 nested_forall_info. */
3296 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3297 gfc_add_expr_to_block (block, tmp);
3300 gfc_add_modify (block, count1, gfc_index_zero_node);
3304 gfc_add_modify (block, count, gfc_index_zero_node);
3306 /* Generate codes to copy the temporary to lhs. */
3307 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
3310 /* Generate body and loops according to the information in
3311 nested_forall_info. */
3312 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3313 gfc_add_expr_to_block (block, tmp);
3317 /* Free the temporary. */
3318 tmp = gfc_call_free (ptemp1);
3319 gfc_add_expr_to_block (block, tmp);
3324 /* Translate pointer assignment inside FORALL which need temporary. */
3327 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3328 forall_info * nested_forall_info,
3329 stmtblock_t * block)
3336 gfc_array_info *info;
3343 tree tmp, tmp1, ptemp1;
3345 count = gfc_create_var (gfc_array_index_type, "count");
3346 gfc_add_modify (block, count, gfc_index_zero_node);
3348 inner_size = gfc_index_one_node;
3349 lss = gfc_walk_expr (expr1);
3350 rss = gfc_walk_expr (expr2);
3351 if (lss == gfc_ss_terminator)
3353 type = gfc_typenode_for_spec (&expr1->ts);
3354 type = build_pointer_type (type);
3356 /* Allocate temporary for nested forall construct according to the
3357 information in nested_forall_info and inner_size. */
3358 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
3359 inner_size, NULL, block, &ptemp1);
3360 gfc_start_block (&body);
3361 gfc_init_se (&lse, NULL);
3362 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3363 gfc_init_se (&rse, NULL);
3364 rse.want_pointer = 1;
3365 gfc_conv_expr (&rse, expr2);
3366 gfc_add_block_to_block (&body, &rse.pre);
3367 gfc_add_modify (&body, lse.expr,
3368 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3369 gfc_add_block_to_block (&body, &rse.post);
3371 /* Increment count. */
3372 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3373 count, gfc_index_one_node);
3374 gfc_add_modify (&body, count, tmp);
3376 tmp = gfc_finish_block (&body);
3378 /* Generate body and loops according to the information in
3379 nested_forall_info. */
3380 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3381 gfc_add_expr_to_block (block, tmp);
3384 gfc_add_modify (block, count, gfc_index_zero_node);
3386 gfc_start_block (&body);
3387 gfc_init_se (&lse, NULL);
3388 gfc_init_se (&rse, NULL);
3389 rse.expr = gfc_build_array_ref (tmp1, count, NULL);
3390 lse.want_pointer = 1;
3391 gfc_conv_expr (&lse, expr1);
3392 gfc_add_block_to_block (&body, &lse.pre);
3393 gfc_add_modify (&body, lse.expr, rse.expr);
3394 gfc_add_block_to_block (&body, &lse.post);
3395 /* Increment count. */
3396 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3397 count, gfc_index_one_node);
3398 gfc_add_modify (&body, count, tmp);
3399 tmp = gfc_finish_block (&body);
3401 /* Generate body and loops according to the information in
3402 nested_forall_info. */
3403 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3404 gfc_add_expr_to_block (block, tmp);
3408 gfc_init_loopinfo (&loop);
3410 /* Associate the SS with the loop. */
3411 gfc_add_ss_to_loop (&loop, rss);
3413 /* Setup the scalarizing loops and bounds. */
3414 gfc_conv_ss_startstride (&loop);
3416 gfc_conv_loop_setup (&loop, &expr2->where);
3418 info = &rss->info->data.array;
3419 desc = info->descriptor;
3421 /* Make a new descriptor. */
3422 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3423 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
3424 loop.from, loop.to, 1,
3425 GFC_ARRAY_UNKNOWN, true);
3427 /* Allocate temporary for nested forall construct. */
3428 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
3429 inner_size, NULL, block, &ptemp1);
3430 gfc_start_block (&body);
3431 gfc_init_se (&lse, NULL);
3432 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3433 lse.direct_byref = 1;
3434 rss = gfc_walk_expr (expr2);
3435 gfc_conv_expr_descriptor (&lse, expr2, rss);
3437 gfc_add_block_to_block (&body, &lse.pre);
3438 gfc_add_block_to_block (&body, &lse.post);
3440 /* Increment count. */
3441 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3442 count, gfc_index_one_node);
3443 gfc_add_modify (&body, count, tmp);
3445 tmp = gfc_finish_block (&body);
3447 /* Generate body and loops according to the information in
3448 nested_forall_info. */
3449 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3450 gfc_add_expr_to_block (block, tmp);
3453 gfc_add_modify (block, count, gfc_index_zero_node);
3455 parm = gfc_build_array_ref (tmp1, count, NULL);
3456 lss = gfc_walk_expr (expr1);
3457 gfc_init_se (&lse, NULL);
3458 gfc_conv_expr_descriptor (&lse, expr1, lss);
3459 gfc_add_modify (&lse.pre, lse.expr, parm);
3460 gfc_start_block (&body);
3461 gfc_add_block_to_block (&body, &lse.pre);
3462 gfc_add_block_to_block (&body, &lse.post);
3464 /* Increment count. */
3465 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3466 count, gfc_index_one_node);
3467 gfc_add_modify (&body, count, tmp);
3469 tmp = gfc_finish_block (&body);
3471 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3472 gfc_add_expr_to_block (block, tmp);
3474 /* Free the temporary. */
3477 tmp = gfc_call_free (ptemp1);
3478 gfc_add_expr_to_block (block, tmp);
3483 /* FORALL and WHERE statements are really nasty, especially when you nest
3484 them. All the rhs of a forall assignment must be evaluated before the
3485 actual assignments are performed. Presumably this also applies to all the
3486 assignments in an inner where statement. */
3488 /* Generate code for a FORALL statement. Any temporaries are allocated as a
3489 linear array, relying on the fact that we process in the same order in all
3492 forall (i=start:end:stride; maskexpr)
3496 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
3498 count = ((end + 1 - start) / stride)
3499 masktmp(:) = maskexpr(:)
3502 for (i = start; i <= end; i += stride)
3504 if (masktmp[maskindex++])
3508 for (i = start; i <= end; i += stride)
3510 if (masktmp[maskindex++])
3514 Note that this code only works when there are no dependencies.
3515 Forall loop with array assignments and data dependencies are a real pain,
3516 because the size of the temporary cannot always be determined before the
3517 loop is executed. This problem is compounded by the presence of nested
3522 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
3539 tree cycle_label = NULL_TREE;
3543 gfc_forall_iterator *fa;
3546 gfc_saved_var *saved_vars;
3547 iter_info *this_forall;
3551 /* Do nothing if the mask is false. */
3553 && code->expr1->expr_type == EXPR_CONSTANT
3554 && !code->expr1->value.logical)
3555 return build_empty_stmt (input_location);
3558 /* Count the FORALL index number. */
3559 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3563 /* Allocate the space for var, start, end, step, varexpr. */
3564 var = XCNEWVEC (tree, nvar);
3565 start = XCNEWVEC (tree, nvar);
3566 end = XCNEWVEC (tree, nvar);
3567 step = XCNEWVEC (tree, nvar);
3568 varexpr = XCNEWVEC (gfc_expr *, nvar);
3569 saved_vars = XCNEWVEC (gfc_saved_var, nvar);
3571 /* Allocate the space for info. */
3572 info = XCNEW (forall_info);
3574 gfc_start_block (&pre);
3575 gfc_init_block (&post);
3576 gfc_init_block (&block);
3579 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3581 gfc_symbol *sym = fa->var->symtree->n.sym;
3583 /* Allocate space for this_forall. */
3584 this_forall = XCNEW (iter_info);
3586 /* Create a temporary variable for the FORALL index. */
3587 tmp = gfc_typenode_for_spec (&sym->ts);
3588 var[n] = gfc_create_var (tmp, sym->name);
3589 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
3591 /* Record it in this_forall. */
3592 this_forall->var = var[n];
3594 /* Replace the index symbol's backend_decl with the temporary decl. */
3595 sym->backend_decl = var[n];
3597 /* Work out the start, end and stride for the loop. */
3598 gfc_init_se (&se, NULL);
3599 gfc_conv_expr_val (&se, fa->start);
3600 /* Record it in this_forall. */
3601 this_forall->start = se.expr;
3602 gfc_add_block_to_block (&block, &se.pre);
3605 gfc_init_se (&se, NULL);
3606 gfc_conv_expr_val (&se, fa->end);
3607 /* Record it in this_forall. */
3608 this_forall->end = se.expr;
3609 gfc_make_safe_expr (&se);
3610 gfc_add_block_to_block (&block, &se.pre);
3613 gfc_init_se (&se, NULL);
3614 gfc_conv_expr_val (&se, fa->stride);
3615 /* Record it in this_forall. */
3616 this_forall->step = se.expr;
3617 gfc_make_safe_expr (&se);
3618 gfc_add_block_to_block (&block, &se.pre);
3621 /* Set the NEXT field of this_forall to NULL. */
3622 this_forall->next = NULL;
3623 /* Link this_forall to the info construct. */
3624 if (info->this_loop)
3626 iter_info *iter_tmp = info->this_loop;
3627 while (iter_tmp->next != NULL)
3628 iter_tmp = iter_tmp->next;
3629 iter_tmp->next = this_forall;
3632 info->this_loop = this_forall;
3638 /* Calculate the size needed for the current forall level. */
3639 size = gfc_index_one_node;
3640 for (n = 0; n < nvar; n++)
3642 /* size = (end + step - start) / step. */
3643 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
3645 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
3647 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
3649 tmp = convert (gfc_array_index_type, tmp);
3651 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3655 /* Record the nvar and size of current forall level. */
3661 /* If the mask is .true., consider the FORALL unconditional. */
3662 if (code->expr1->expr_type == EXPR_CONSTANT
3663 && code->expr1->value.logical)
3671 /* First we need to allocate the mask. */
3674 /* As the mask array can be very big, prefer compact boolean types. */
3675 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3676 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
3677 size, NULL, &block, &pmask);
3678 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
3680 /* Record them in the info structure. */
3681 info->maskindex = maskindex;
3686 /* No mask was specified. */
3687 maskindex = NULL_TREE;
3688 mask = pmask = NULL_TREE;
3691 /* Link the current forall level to nested_forall_info. */
3692 info->prev_nest = nested_forall_info;
3693 nested_forall_info = info;
3695 /* Copy the mask into a temporary variable if required.
3696 For now we assume a mask temporary is needed. */
3699 /* As the mask array can be very big, prefer compact boolean types. */
3700 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3702 gfc_add_modify (&block, maskindex, gfc_index_zero_node);
3704 /* Start of mask assignment loop body. */
3705 gfc_start_block (&body);
3707 /* Evaluate the mask expression. */
3708 gfc_init_se (&se, NULL);
3709 gfc_conv_expr_val (&se, code->expr1);
3710 gfc_add_block_to_block (&body, &se.pre);
3712 /* Store the mask. */
3713 se.expr = convert (mask_type, se.expr);
3715 tmp = gfc_build_array_ref (mask, maskindex, NULL);
3716 gfc_add_modify (&body, tmp, se.expr);
3718 /* Advance to the next mask element. */
3719 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3720 maskindex, gfc_index_one_node);
3721 gfc_add_modify (&body, maskindex, tmp);
3723 /* Generate the loops. */
3724 tmp = gfc_finish_block (&body);
3725 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
3726 gfc_add_expr_to_block (&block, tmp);
3729 if (code->op == EXEC_DO_CONCURRENT)
3731 gfc_init_block (&body);
3732 cycle_label = gfc_build_label_decl (NULL_TREE);
3733 code->cycle_label = cycle_label;
3734 tmp = gfc_trans_code (code->block->next);
3735 gfc_add_expr_to_block (&body, tmp);
3737 if (TREE_USED (cycle_label))
3739 tmp = build1_v (LABEL_EXPR, cycle_label);
3740 gfc_add_expr_to_block (&body, tmp);
3743 tmp = gfc_finish_block (&body);
3744 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3745 gfc_add_expr_to_block (&block, tmp);
3749 c = code->block->next;
3751 /* TODO: loop merging in FORALL statements. */
3752 /* Now that we've got a copy of the mask, generate the assignment loops. */
3758 /* A scalar or array assignment. DO the simple check for
3759 lhs to rhs dependencies. These make a temporary for the
3760 rhs and form a second forall block to copy to variable. */
3761 need_temp = check_forall_dependencies(c, &pre, &post);
3763 /* Temporaries due to array assignment data dependencies introduce
3764 no end of problems. */
3766 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
3767 nested_forall_info, &block);
3770 /* Use the normal assignment copying routines. */
3771 assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
3773 /* Generate body and loops. */
3774 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3776 gfc_add_expr_to_block (&block, tmp);
3779 /* Cleanup any temporary symtrees that have been made to deal
3780 with dependencies. */
3782 cleanup_forall_symtrees (c);
3787 /* Translate WHERE or WHERE construct nested in FORALL. */
3788 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
3791 /* Pointer assignment inside FORALL. */
3792 case EXEC_POINTER_ASSIGN:
3793 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
3795 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
3796 nested_forall_info, &block);
3799 /* Use the normal assignment copying routines. */
3800 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
3802 /* Generate body and loops. */
3803 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3805 gfc_add_expr_to_block (&block, tmp);
3810 tmp = gfc_trans_forall_1 (c, nested_forall_info);
3811 gfc_add_expr_to_block (&block, tmp);
3814 /* Explicit subroutine calls are prevented by the frontend but interface
3815 assignments can legitimately produce them. */
3816 case EXEC_ASSIGN_CALL:
3817 assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
3818 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
3819 gfc_add_expr_to_block (&block, tmp);
3830 /* Restore the original index variables. */
3831 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
3832 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
3834 /* Free the space for var, start, end, step, varexpr. */
3842 for (this_forall = info->this_loop; this_forall;)
3844 iter_info *next = this_forall->next;
3849 /* Free the space for this forall_info. */
3854 /* Free the temporary for the mask. */
3855 tmp = gfc_call_free (pmask);
3856 gfc_add_expr_to_block (&block, tmp);
3859 pushdecl (maskindex);
3861 gfc_add_block_to_block (&pre, &block);
3862 gfc_add_block_to_block (&pre, &post);
3864 return gfc_finish_block (&pre);
3868 /* Translate the FORALL statement or construct. */
3870 tree gfc_trans_forall (gfc_code * code)
3872 return gfc_trans_forall_1 (code, NULL);
3876 /* Translate the DO CONCURRENT construct. */
3878 tree gfc_trans_do_concurrent (gfc_code * code)
3880 return gfc_trans_forall_1 (code, NULL);
3884 /* Evaluate the WHERE mask expression, copy its value to a temporary.
3885 If the WHERE construct is nested in FORALL, compute the overall temporary
3886 needed by the WHERE mask expression multiplied by the iterator number of
3888 ME is the WHERE mask expression.
3889 MASK is the current execution mask upon input, whose sense may or may
3890 not be inverted as specified by the INVERT argument.
3891 CMASK is the updated execution mask on output, or NULL if not required.
3892 PMASK is the pending execution mask on output, or NULL if not required.
3893 BLOCK is the block in which to place the condition evaluation loops. */
3896 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
3897 tree mask, bool invert, tree cmask, tree pmask,
3898 tree mask_type, stmtblock_t * block)
3903 stmtblock_t body, body1;
3904 tree count, cond, mtmp;
3907 gfc_init_loopinfo (&loop);
3909 lss = gfc_walk_expr (me);
3910 rss = gfc_walk_expr (me);
3912 /* Variable to index the temporary. */
3913 count = gfc_create_var (gfc_array_index_type, "count");
3914 /* Initialize count. */
3915 gfc_add_modify (block, count, gfc_index_zero_node);
3917 gfc_start_block (&body);
3919 gfc_init_se (&rse, NULL);
3920 gfc_init_se (&lse, NULL);
3922 if (lss == gfc_ss_terminator)
3924 gfc_init_block (&body1);
3928 /* Initialize the loop. */
3929 gfc_init_loopinfo (&loop);
3931 /* We may need LSS to determine the shape of the expression. */
3932 gfc_add_ss_to_loop (&loop, lss);
3933 gfc_add_ss_to_loop (&loop, rss);
3935 gfc_conv_ss_startstride (&loop);
3936 gfc_conv_loop_setup (&loop, &me->where);
3938 gfc_mark_ss_chain_used (rss, 1);
3939 /* Start the loop body. */
3940 gfc_start_scalarized_body (&loop, &body1);
3942 /* Translate the expression. */
3943 gfc_copy_loopinfo_to_se (&rse, &loop);
3945 gfc_conv_expr (&rse, me);
3948 /* Variable to evaluate mask condition. */
3949 cond = gfc_create_var (mask_type, "cond");
3950 if (mask && (cmask || pmask))
3951 mtmp = gfc_create_var (mask_type, "mask");
3952 else mtmp = NULL_TREE;
3954 gfc_add_block_to_block (&body1, &lse.pre);
3955 gfc_add_block_to_block (&body1, &rse.pre);
3957 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
3959 if (mask && (cmask || pmask))
3961 tmp = gfc_build_array_ref (mask, count, NULL);
3963 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
3964 gfc_add_modify (&body1, mtmp, tmp);
3969 tmp1 = gfc_build_array_ref (cmask, count, NULL);
3972 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
3974 gfc_add_modify (&body1, tmp1, tmp);
3979 tmp1 = gfc_build_array_ref (pmask, count, NULL);
3980 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
3982 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
3984 gfc_add_modify (&body1, tmp1, tmp);
3987 gfc_add_block_to_block (&body1, &lse.post);
3988 gfc_add_block_to_block (&body1, &rse.post);
3990 if (lss == gfc_ss_terminator)
3992 gfc_add_block_to_block (&body, &body1);
3996 /* Increment count. */
3997 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3998 count, gfc_index_one_node);
3999 gfc_add_modify (&body1, count, tmp1);
4001 /* Generate the copying loops. */
4002 gfc_trans_scalarizing_loops (&loop, &body1);
4004 gfc_add_block_to_block (&body, &loop.pre);
4005 gfc_add_block_to_block (&body, &loop.post);
4007 gfc_cleanup_loop (&loop);
4008 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4009 as tree nodes in SS may not be valid in different scope. */
4012 tmp1 = gfc_finish_block (&body);
4013 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4014 if (nested_forall_info != NULL)
4015 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
4017 gfc_add_expr_to_block (block, tmp1);
4021 /* Translate an assignment statement in a WHERE statement or construct
4022 statement. The MASK expression is used to control which elements
4023 of EXPR1 shall be assigned. The sense of MASK is specified by
4027 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
4028 tree mask, bool invert,
4029 tree count1, tree count2,
4035 gfc_ss *lss_section;
4042 tree index, maskexpr;
4044 /* A defined assignment. */
4045 if (cnext && cnext->resolved_sym)
4046 return gfc_trans_call (cnext, true, mask, count1, invert);
4049 /* TODO: handle this special case.
4050 Special case a single function returning an array. */
4051 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4053 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4059 /* Assignment of the form lhs = rhs. */
4060 gfc_start_block (&block);
4062 gfc_init_se (&lse, NULL);
4063 gfc_init_se (&rse, NULL);
4066 lss = gfc_walk_expr (expr1);
4069 /* In each where-assign-stmt, the mask-expr and the variable being
4070 defined shall be arrays of the same shape. */
4071 gcc_assert (lss != gfc_ss_terminator);
4073 /* The assignment needs scalarization. */
4076 /* Find a non-scalar SS from the lhs. */
4077 while (lss_section != gfc_ss_terminator
4078 && lss_section->info->type != GFC_SS_SECTION)
4079 lss_section = lss_section->next;
4081 gcc_assert (lss_section != gfc_ss_terminator);
4083 /* Initialize the scalarizer. */
4084 gfc_init_loopinfo (&loop);
4087 rss = gfc_walk_expr (expr2);
4088 if (rss == gfc_ss_terminator)
4090 /* The rhs is scalar. Add a ss for the expression. */
4091 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4092 rss->info->where = 1;
4095 /* Associate the SS with the loop. */
4096 gfc_add_ss_to_loop (&loop, lss);
4097 gfc_add_ss_to_loop (&loop, rss);
4099 /* Calculate the bounds of the scalarization. */
4100 gfc_conv_ss_startstride (&loop);
4102 /* Resolve any data dependencies in the statement. */
4103 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
4105 /* Setup the scalarizing loops. */
4106 gfc_conv_loop_setup (&loop, &expr2->where);
4108 /* Setup the gfc_se structures. */
4109 gfc_copy_loopinfo_to_se (&lse, &loop);
4110 gfc_copy_loopinfo_to_se (&rse, &loop);
4113 gfc_mark_ss_chain_used (rss, 1);
4114 if (loop.temp_ss == NULL)
4117 gfc_mark_ss_chain_used (lss, 1);
4121 lse.ss = loop.temp_ss;
4122 gfc_mark_ss_chain_used (lss, 3);
4123 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4126 /* Start the scalarized loop body. */
4127 gfc_start_scalarized_body (&loop, &body);
4129 /* Translate the expression. */
4130 gfc_conv_expr (&rse, expr2);
4131 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
4132 gfc_conv_tmp_array_ref (&lse);
4134 gfc_conv_expr (&lse, expr1);
4136 /* Form the mask expression according to the mask. */
4138 maskexpr = gfc_build_array_ref (mask, index, NULL);
4140 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4141 TREE_TYPE (maskexpr), maskexpr);
4143 /* Use the scalar assignment as is. */
4144 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4145 loop.temp_ss != NULL, false, true);
4147 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
4149 gfc_add_expr_to_block (&body, tmp);
4151 if (lss == gfc_ss_terminator)
4153 /* Increment count1. */
4154 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4155 count1, gfc_index_one_node);
4156 gfc_add_modify (&body, count1, tmp);
4158 /* Use the scalar assignment as is. */
4159 gfc_add_block_to_block (&block, &body);
4163 gcc_assert (lse.ss == gfc_ss_terminator
4164 && rse.ss == gfc_ss_terminator);
4166 if (loop.temp_ss != NULL)
4168 /* Increment count1 before finish the main body of a scalarized
4170 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4171 gfc_array_index_type, count1, gfc_index_one_node);
4172 gfc_add_modify (&body, count1, tmp);
4173 gfc_trans_scalarized_loop_boundary (&loop, &body);
4175 /* We need to copy the temporary to the actual lhs. */
4176 gfc_init_se (&lse, NULL);
4177 gfc_init_se (&rse, NULL);
4178 gfc_copy_loopinfo_to_se (&lse, &loop);
4179 gfc_copy_loopinfo_to_se (&rse, &loop);
4181 rse.ss = loop.temp_ss;
4184 gfc_conv_tmp_array_ref (&rse);
4185 gfc_conv_expr (&lse, expr1);
4187 gcc_assert (lse.ss == gfc_ss_terminator
4188 && rse.ss == gfc_ss_terminator);
4190 /* Form the mask expression according to the mask tree list. */
4192 maskexpr = gfc_build_array_ref (mask, index, NULL);
4194 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4195 TREE_TYPE (maskexpr), maskexpr);
4197 /* Use the scalar assignment as is. */
4198 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
4200 tmp = build3_v (COND_EXPR, maskexpr, tmp,
4201 build_empty_stmt (input_location));
4202 gfc_add_expr_to_block (&body, tmp);
4204 /* Increment count2. */
4205 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4206 gfc_array_index_type, count2,
4207 gfc_index_one_node);
4208 gfc_add_modify (&body, count2, tmp);
4212 /* Increment count1. */
4213 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4214 gfc_array_index_type, count1,
4215 gfc_index_one_node);
4216 gfc_add_modify (&body, count1, tmp);
4219 /* Generate the copying loops. */
4220 gfc_trans_scalarizing_loops (&loop, &body);
4222 /* Wrap the whole thing up. */
4223 gfc_add_block_to_block (&block, &loop.pre);
4224 gfc_add_block_to_block (&block, &loop.post);
4225 gfc_cleanup_loop (&loop);
4228 return gfc_finish_block (&block);
4232 /* Translate the WHERE construct or statement.
4233 This function can be called iteratively to translate the nested WHERE
4234 construct or statement.
4235 MASK is the control mask. */
4238 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
4239 forall_info * nested_forall_info, stmtblock_t * block)
4241 stmtblock_t inner_size_body;
4242 tree inner_size, size;
4251 tree count1, count2;
4255 tree pcmask = NULL_TREE;
4256 tree ppmask = NULL_TREE;
4257 tree cmask = NULL_TREE;
4258 tree pmask = NULL_TREE;
4259 gfc_actual_arglist *arg;
4261 /* the WHERE statement or the WHERE construct statement. */
4262 cblock = code->block;
4264 /* As the mask array can be very big, prefer compact boolean types. */
4265 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
4267 /* Determine which temporary masks are needed. */
4270 /* One clause: No ELSEWHEREs. */
4271 need_cmask = (cblock->next != 0);
4274 else if (cblock->block->block)
4276 /* Three or more clauses: Conditional ELSEWHEREs. */
4280 else if (cblock->next)
4282 /* Two clauses, the first non-empty. */
4284 need_pmask = (mask != NULL_TREE
4285 && cblock->block->next != 0);
4287 else if (!cblock->block->next)
4289 /* Two clauses, both empty. */
4293 /* Two clauses, the first empty, the second non-empty. */
4296 need_cmask = (cblock->block->expr1 != 0);
4305 if (need_cmask || need_pmask)
4307 /* Calculate the size of temporary needed by the mask-expr. */
4308 gfc_init_block (&inner_size_body);
4309 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
4310 &inner_size_body, &lss, &rss);
4312 gfc_free_ss_chain (lss);
4313 gfc_free_ss_chain (rss);
4315 /* Calculate the total size of temporary needed. */
4316 size = compute_overall_iter_number (nested_forall_info, inner_size,
4317 &inner_size_body, block);
4319 /* Check whether the size is negative. */
4320 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
4321 gfc_index_zero_node);
4322 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4323 cond, gfc_index_zero_node, size);
4324 size = gfc_evaluate_now (size, block);
4326 /* Allocate temporary for WHERE mask if needed. */
4328 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4331 /* Allocate temporary for !mask if needed. */
4333 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4339 /* Each time around this loop, the where clause is conditional
4340 on the value of mask and invert, which are updated at the
4341 bottom of the loop. */
4343 /* Has mask-expr. */
4346 /* Ensure that the WHERE mask will be evaluated exactly once.
4347 If there are no statements in this WHERE/ELSEWHERE clause,
4348 then we don't need to update the control mask (cmask).
4349 If this is the last clause of the WHERE construct, then
4350 we don't need to update the pending control mask (pmask). */
4352 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4354 cblock->next ? cmask : NULL_TREE,
4355 cblock->block ? pmask : NULL_TREE,
4358 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4360 (cblock->next || cblock->block)
4361 ? cmask : NULL_TREE,
4362 NULL_TREE, mask_type, block);
4366 /* It's a final elsewhere-stmt. No mask-expr is present. */
4370 /* The body of this where clause are controlled by cmask with
4371 sense specified by invert. */
4373 /* Get the assignment statement of a WHERE statement, or the first
4374 statement in where-body-construct of a WHERE construct. */
4375 cnext = cblock->next;
4380 /* WHERE assignment statement. */
4381 case EXEC_ASSIGN_CALL:
4383 arg = cnext->ext.actual;
4384 expr1 = expr2 = NULL;
4385 for (; arg; arg = arg->next)
4397 expr1 = cnext->expr1;
4398 expr2 = cnext->expr2;
4400 if (nested_forall_info != NULL)
4402 need_temp = gfc_check_dependency (expr1, expr2, 0);
4403 if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
4404 gfc_trans_assign_need_temp (expr1, expr2,
4406 nested_forall_info, block);
4409 /* Variables to control maskexpr. */
4410 count1 = gfc_create_var (gfc_array_index_type, "count1");
4411 count2 = gfc_create_var (gfc_array_index_type, "count2");
4412 gfc_add_modify (block, count1, gfc_index_zero_node);
4413 gfc_add_modify (block, count2, gfc_index_zero_node);
4415 tmp = gfc_trans_where_assign (expr1, expr2,
4420 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
4422 gfc_add_expr_to_block (block, tmp);
4427 /* Variables to control maskexpr. */
4428 count1 = gfc_create_var (gfc_array_index_type, "count1");
4429 count2 = gfc_create_var (gfc_array_index_type, "count2");
4430 gfc_add_modify (block, count1, gfc_index_zero_node);
4431 gfc_add_modify (block, count2, gfc_index_zero_node);
4433 tmp = gfc_trans_where_assign (expr1, expr2,
4437 gfc_add_expr_to_block (block, tmp);
4442 /* WHERE or WHERE construct is part of a where-body-construct. */
4444 gfc_trans_where_2 (cnext, cmask, invert,
4445 nested_forall_info, block);
4452 /* The next statement within the same where-body-construct. */
4453 cnext = cnext->next;
4455 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
4456 cblock = cblock->block;
4457 if (mask == NULL_TREE)
4459 /* If we're the initial WHERE, we can simply invert the sense
4460 of the current mask to obtain the "mask" for the remaining
4467 /* Otherwise, for nested WHERE's we need to use the pending mask. */
4473 /* If we allocated a pending mask array, deallocate it now. */
4476 tmp = gfc_call_free (ppmask);
4477 gfc_add_expr_to_block (block, tmp);
4480 /* If we allocated a current mask array, deallocate it now. */
4483 tmp = gfc_call_free (pcmask);
4484 gfc_add_expr_to_block (block, tmp);
4488 /* Translate a simple WHERE construct or statement without dependencies.
4489 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
4490 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
4491 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
4494 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
4496 stmtblock_t block, body;
4497 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
4498 tree tmp, cexpr, tstmt, estmt;
4499 gfc_ss *css, *tdss, *tsss;
4500 gfc_se cse, tdse, tsse, edse, esse;
4505 /* Allow the scalarizer to workshare simple where loops. */
4506 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4507 ompws_flags |= OMPWS_SCALARIZER_WS;
4509 cond = cblock->expr1;
4510 tdst = cblock->next->expr1;
4511 tsrc = cblock->next->expr2;
4512 edst = eblock ? eblock->next->expr1 : NULL;
4513 esrc = eblock ? eblock->next->expr2 : NULL;
4515 gfc_start_block (&block);
4516 gfc_init_loopinfo (&loop);
4518 /* Handle the condition. */
4519 gfc_init_se (&cse, NULL);
4520 css = gfc_walk_expr (cond);
4521 gfc_add_ss_to_loop (&loop, css);
4523 /* Handle the then-clause. */
4524 gfc_init_se (&tdse, NULL);
4525 gfc_init_se (&tsse, NULL);
4526 tdss = gfc_walk_expr (tdst);
4527 tsss = gfc_walk_expr (tsrc);
4528 if (tsss == gfc_ss_terminator)
4530 tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
4531 tsss->info->where = 1;
4533 gfc_add_ss_to_loop (&loop, tdss);
4534 gfc_add_ss_to_loop (&loop, tsss);
4538 /* Handle the else clause. */
4539 gfc_init_se (&edse, NULL);
4540 gfc_init_se (&esse, NULL);
4541 edss = gfc_walk_expr (edst);
4542 esss = gfc_walk_expr (esrc);
4543 if (esss == gfc_ss_terminator)
4545 esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
4546 esss->info->where = 1;
4548 gfc_add_ss_to_loop (&loop, edss);
4549 gfc_add_ss_to_loop (&loop, esss);
4552 gfc_conv_ss_startstride (&loop);
4553 gfc_conv_loop_setup (&loop, &tdst->where);
4555 gfc_mark_ss_chain_used (css, 1);
4556 gfc_mark_ss_chain_used (tdss, 1);
4557 gfc_mark_ss_chain_used (tsss, 1);
4560 gfc_mark_ss_chain_used (edss, 1);
4561 gfc_mark_ss_chain_used (esss, 1);
4564 gfc_start_scalarized_body (&loop, &body);
4566 gfc_copy_loopinfo_to_se (&cse, &loop);
4567 gfc_copy_loopinfo_to_se (&tdse, &loop);
4568 gfc_copy_loopinfo_to_se (&tsse, &loop);
4574 gfc_copy_loopinfo_to_se (&edse, &loop);
4575 gfc_copy_loopinfo_to_se (&esse, &loop);
4580 gfc_conv_expr (&cse, cond);
4581 gfc_add_block_to_block (&body, &cse.pre);
4584 gfc_conv_expr (&tsse, tsrc);
4585 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
4586 gfc_conv_tmp_array_ref (&tdse);
4588 gfc_conv_expr (&tdse, tdst);
4592 gfc_conv_expr (&esse, esrc);
4593 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
4594 gfc_conv_tmp_array_ref (&edse);
4596 gfc_conv_expr (&edse, edst);
4599 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
4600 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
4602 : build_empty_stmt (input_location);
4603 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
4604 gfc_add_expr_to_block (&body, tmp);
4605 gfc_add_block_to_block (&body, &cse.post);
4607 gfc_trans_scalarizing_loops (&loop, &body);
4608 gfc_add_block_to_block (&block, &loop.pre);
4609 gfc_add_block_to_block (&block, &loop.post);
4610 gfc_cleanup_loop (&loop);
4612 return gfc_finish_block (&block);
4615 /* As the WHERE or WHERE construct statement can be nested, we call
4616 gfc_trans_where_2 to do the translation, and pass the initial
4617 NULL values for both the control mask and the pending control mask. */
4620 gfc_trans_where (gfc_code * code)
4626 cblock = code->block;
4628 && cblock->next->op == EXEC_ASSIGN
4629 && !cblock->next->next)
4631 eblock = cblock->block;
4634 /* A simple "WHERE (cond) x = y" statement or block is
4635 dependence free if cond is not dependent upon writing x,
4636 and the source y is unaffected by the destination x. */
4637 if (!gfc_check_dependency (cblock->next->expr1,
4639 && !gfc_check_dependency (cblock->next->expr1,
4640 cblock->next->expr2, 0))
4641 return gfc_trans_where_3 (cblock, NULL);
4643 else if (!eblock->expr1
4646 && eblock->next->op == EXEC_ASSIGN
4647 && !eblock->next->next)
4649 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
4650 block is dependence free if cond is not dependent on writes
4651 to x1 and x2, y1 is not dependent on writes to x2, and y2
4652 is not dependent on writes to x1, and both y's are not
4653 dependent upon their own x's. In addition to this, the
4654 final two dependency checks below exclude all but the same
4655 array reference if the where and elswhere destinations
4656 are the same. In short, this is VERY conservative and this
4657 is needed because the two loops, required by the standard
4658 are coalesced in gfc_trans_where_3. */
4659 if (!gfc_check_dependency(cblock->next->expr1,
4661 && !gfc_check_dependency(eblock->next->expr1,
4663 && !gfc_check_dependency(cblock->next->expr1,
4664 eblock->next->expr2, 1)
4665 && !gfc_check_dependency(eblock->next->expr1,
4666 cblock->next->expr2, 1)
4667 && !gfc_check_dependency(cblock->next->expr1,
4668 cblock->next->expr2, 1)
4669 && !gfc_check_dependency(eblock->next->expr1,
4670 eblock->next->expr2, 1)
4671 && !gfc_check_dependency(cblock->next->expr1,
4672 eblock->next->expr1, 0)
4673 && !gfc_check_dependency(eblock->next->expr1,
4674 cblock->next->expr1, 0))
4675 return gfc_trans_where_3 (cblock, eblock);
4679 gfc_start_block (&block);
4681 gfc_trans_where_2 (code, NULL, false, NULL, &block);
4683 return gfc_finish_block (&block);
4687 /* CYCLE a DO loop. The label decl has already been created by
4688 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
4689 node at the head of the loop. We must mark the label as used. */
4692 gfc_trans_cycle (gfc_code * code)
4696 cycle_label = code->ext.which_construct->cycle_label;
4697 gcc_assert (cycle_label);
4699 TREE_USED (cycle_label) = 1;
4700 return build1_v (GOTO_EXPR, cycle_label);
4704 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
4705 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
4709 gfc_trans_exit (gfc_code * code)
4713 exit_label = code->ext.which_construct->exit_label;
4714 gcc_assert (exit_label);
4716 TREE_USED (exit_label) = 1;
4717 return build1_v (GOTO_EXPR, exit_label);
4721 /* Translate the ALLOCATE statement. */
4724 gfc_trans_allocate (gfc_code * code)
4746 tree memsize = NULL_TREE;
4747 tree classexpr = NULL_TREE;
4749 if (!code->ext.alloc.list)
4752 stat = tmp = memsz = NULL_TREE;
4753 label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
4755 gfc_init_block (&block);
4756 gfc_init_block (&post);
4758 /* STAT= (and maybe ERRMSG=) is present. */
4762 tree gfc_int4_type_node = gfc_get_int_type (4);
4763 stat = gfc_create_var (gfc_int4_type_node, "stat");
4765 /* ERRMSG= only makes sense with STAT=. */
4768 gfc_init_se (&se, NULL);
4769 se.want_pointer = 1;
4770 gfc_conv_expr_lhs (&se, code->expr2);
4772 errlen = se.string_length;
4776 errmsg = null_pointer_node;
4777 errlen = build_int_cst (gfc_charlen_type_node, 0);
4780 /* GOTO destinations. */
4781 label_errmsg = gfc_build_label_decl (NULL_TREE);
4782 label_finish = gfc_build_label_decl (NULL_TREE);
4783 TREE_USED (label_finish) = 0;
4789 for (al = code->ext.alloc.list; al != NULL; al = al->next)
4791 expr = gfc_copy_expr (al->expr);
4793 if (expr->ts.type == BT_CLASS)
4794 gfc_add_data_component (expr);
4796 gfc_init_se (&se, NULL);
4798 se.want_pointer = 1;
4799 se.descriptor_only = 1;
4800 gfc_conv_expr (&se, expr);
4802 /* Evaluate expr3 just once if not a variable. */
4803 if (al == code->ext.alloc.list
4804 && al->expr->ts.type == BT_CLASS
4806 && code->expr3->ts.type == BT_CLASS
4807 && code->expr3->expr_type != EXPR_VARIABLE)
4809 gfc_init_se (&se_sz, NULL);
4810 gfc_conv_expr_reference (&se_sz, code->expr3);
4811 gfc_conv_class_to_class (&se_sz, code->expr3,
4812 code->expr3->ts, false);
4813 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4814 gfc_add_block_to_block (&se.post, &se_sz.post);
4815 classexpr = build_fold_indirect_ref_loc (input_location,
4817 classexpr = gfc_evaluate_now (classexpr, &se.pre);
4818 memsize = gfc_vtable_size_get (classexpr);
4819 memsize = fold_convert (sizetype, memsize);
4823 class_expr = classexpr;
4826 if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
4827 memsz, &nelems, code->expr3))
4829 /* A scalar or derived type. */
4831 /* Determine allocate size. */
4832 if (al->expr->ts.type == BT_CLASS
4834 && memsz == NULL_TREE)
4836 if (code->expr3->ts.type == BT_CLASS)
4838 sz = gfc_copy_expr (code->expr3);
4839 gfc_add_vptr_component (sz);
4840 gfc_add_size_component (sz);
4841 gfc_init_se (&se_sz, NULL);
4842 gfc_conv_expr (&se_sz, sz);
4847 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
4849 else if (al->expr->ts.type == BT_CHARACTER
4850 && al->expr->ts.deferred && code->expr3)
4852 if (!code->expr3->ts.u.cl->backend_decl)
4854 /* Convert and use the length expression. */
4855 gfc_init_se (&se_sz, NULL);
4856 if (code->expr3->expr_type == EXPR_VARIABLE
4857 || code->expr3->expr_type == EXPR_CONSTANT)
4859 gfc_conv_expr (&se_sz, code->expr3);
4860 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4862 = gfc_evaluate_now (se_sz.string_length, &se.pre);
4863 gfc_add_block_to_block (&se.pre, &se_sz.post);
4864 memsz = se_sz.string_length;
4866 else if (code->expr3->mold
4867 && code->expr3->ts.u.cl
4868 && code->expr3->ts.u.cl->length)
4870 gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
4871 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4872 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
4873 gfc_add_block_to_block (&se.pre, &se_sz.post);
4878 /* This is would be inefficient and possibly could
4879 generate wrong code if the result were not stored
4881 if (slen3 == NULL_TREE)
4883 gfc_conv_expr (&se_sz, code->expr3);
4884 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4885 expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
4886 gfc_add_block_to_block (&post, &se_sz.post);
4887 slen3 = gfc_evaluate_now (se_sz.string_length,
4894 /* Otherwise use the stored string length. */
4895 memsz = code->expr3->ts.u.cl->backend_decl;
4896 tmp = al->expr->ts.u.cl->backend_decl;
4898 /* Store the string length. */
4899 if (tmp && TREE_CODE (tmp) == VAR_DECL)
4900 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
4903 /* Convert to size in bytes, using the character KIND. */
4904 tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
4905 tmp = TYPE_SIZE_UNIT (tmp);
4906 memsz = fold_build2_loc (input_location, MULT_EXPR,
4907 TREE_TYPE (tmp), tmp,
4908 fold_convert (TREE_TYPE (tmp), memsz));
4910 else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
4912 gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
4913 gfc_init_se (&se_sz, NULL);
4914 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
4915 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4916 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
4917 gfc_add_block_to_block (&se.pre, &se_sz.post);
4918 /* Store the string length. */
4919 tmp = al->expr->ts.u.cl->backend_decl;
4920 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
4922 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
4923 tmp = TYPE_SIZE_UNIT (tmp);
4924 memsz = fold_build2_loc (input_location, MULT_EXPR,
4925 TREE_TYPE (tmp), tmp,
4926 fold_convert (TREE_TYPE (se_sz.expr),
4929 else if (code->ext.alloc.ts.type != BT_UNKNOWN)
4930 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
4931 else if (memsz == NULL_TREE)
4932 memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
4934 if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
4936 memsz = se.string_length;
4938 /* Convert to size in bytes, using the character KIND. */
4939 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
4940 tmp = TYPE_SIZE_UNIT (tmp);
4941 memsz = fold_build2_loc (input_location, MULT_EXPR,
4942 TREE_TYPE (tmp), tmp,
4943 fold_convert (TREE_TYPE (tmp), memsz));
4946 /* Allocate - for non-pointers with re-alloc checking. */
4947 if (gfc_expr_attr (expr).allocatable)
4948 gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
4949 stat, errmsg, errlen, label_finish, expr);
4951 gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
4953 if (al->expr->ts.type == BT_DERIVED
4954 && expr->ts.u.derived->attr.alloc_comp)
4956 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
4957 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
4958 gfc_add_expr_to_block (&se.pre, tmp);
4960 else if (al->expr->ts.type == BT_CLASS && code->expr3)
4962 /* With class objects, it is best to play safe and null the
4963 memory because we cannot know if dynamic types have allocatable
4964 components or not. */
4965 tmp = build_call_expr_loc (input_location,
4966 builtin_decl_explicit (BUILT_IN_MEMSET),
4967 3, se.expr, integer_zero_node, memsz);
4968 gfc_add_expr_to_block (&se.pre, tmp);
4972 gfc_add_block_to_block (&block, &se.pre);
4974 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
4977 tmp = build1_v (GOTO_EXPR, label_errmsg);
4978 parm = fold_build2_loc (input_location, NE_EXPR,
4979 boolean_type_node, stat,
4980 build_int_cst (TREE_TYPE (stat), 0));
4981 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4982 gfc_unlikely (parm), tmp,
4983 build_empty_stmt (input_location));
4984 gfc_add_expr_to_block (&block, tmp);
4987 /* We need the vptr of CLASS objects to be initialized. */
4988 e = gfc_copy_expr (al->expr);
4989 if (e->ts.type == BT_CLASS)
4991 gfc_expr *lhs, *rhs;
4994 lhs = gfc_expr_to_initialize (e);
4995 gfc_add_vptr_component (lhs);
4997 if (class_expr != NULL_TREE)
4999 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5000 gfc_init_se (&lse, NULL);
5001 lse.want_pointer = 1;
5002 gfc_conv_expr (&lse, lhs);
5003 tmp = gfc_class_vptr_get (class_expr);
5004 gfc_add_modify (&block, lse.expr,
5005 fold_convert (TREE_TYPE (lse.expr), tmp));
5007 else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
5009 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5010 rhs = gfc_copy_expr (code->expr3);
5011 gfc_add_vptr_component (rhs);
5012 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5013 gfc_add_expr_to_block (&block, tmp);
5014 gfc_free_expr (rhs);
5015 rhs = gfc_expr_to_initialize (e);
5019 /* VPTR is fixed at compile time. */
5023 ts = &code->expr3->ts;
5024 else if (e->ts.type == BT_DERIVED)
5026 else if (code->ext.alloc.ts.type == BT_DERIVED)
5027 ts = &code->ext.alloc.ts;
5028 else if (e->ts.type == BT_CLASS)
5029 ts = &CLASS_DATA (e)->ts;
5033 if (ts->type == BT_DERIVED)
5035 vtab = gfc_find_derived_vtab (ts->u.derived);
5037 gfc_init_se (&lse, NULL);
5038 lse.want_pointer = 1;
5039 gfc_conv_expr (&lse, lhs);
5040 tmp = gfc_build_addr_expr (NULL_TREE,
5041 gfc_get_symbol_decl (vtab));
5042 gfc_add_modify (&block, lse.expr,
5043 fold_convert (TREE_TYPE (lse.expr), tmp));
5046 gfc_free_expr (lhs);
5051 if (code->expr3 && !code->expr3->mold)
5053 /* Initialization via SOURCE block
5054 (or static default initializer). */
5055 gfc_expr *rhs = gfc_copy_expr (code->expr3);
5056 if (class_expr != NULL_TREE)
5059 to = TREE_OPERAND (se.expr, 0);
5061 tmp = gfc_copy_class_to_class (class_expr, to, nelems);
5063 else if (al->expr->ts.type == BT_CLASS)
5065 gfc_actual_arglist *actual;
5070 /* Do a polymorphic deep copy. */
5071 actual = gfc_get_actual_arglist ();
5072 actual->expr = gfc_copy_expr (rhs);
5073 if (rhs->ts.type == BT_CLASS)
5074 gfc_add_data_component (actual->expr);
5075 actual->next = gfc_get_actual_arglist ();
5076 actual->next->expr = gfc_copy_expr (al->expr);
5077 actual->next->expr->ts.type = BT_CLASS;
5078 gfc_add_data_component (actual->next->expr);
5079 dataref = actual->next->expr->ref;
5080 if (dataref->u.c.component->as)
5084 gfc_ref *ref = dataref->next;
5085 ref->u.ar.type = AR_SECTION;
5086 /* We have to set up the array reference to give ranges
5087 in all dimensions and ensure that the end and stride
5088 are set so that the copy can be scalarized. */
5090 for (; dim < dataref->u.c.component->as->rank; dim++)
5092 ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
5093 if (ref->u.ar.end[dim] == NULL)
5095 ref->u.ar.end[dim] = ref->u.ar.start[dim];
5096 temp = gfc_get_int_expr (gfc_default_integer_kind,
5097 &al->expr->where, 1);
5098 ref->u.ar.start[dim] = temp;
5100 temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
5101 gfc_copy_expr (ref->u.ar.start[dim]));
5102 temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
5103 &al->expr->where, 1),
5107 if (rhs->ts.type == BT_CLASS)
5109 ppc = gfc_copy_expr (rhs);
5110 gfc_add_vptr_component (ppc);
5113 ppc = gfc_lval_expr_from_sym
5114 (gfc_find_derived_vtab (rhs->ts.u.derived));
5115 gfc_add_component_ref (ppc, "_copy");
5117 ppc_code = gfc_get_code ();
5118 ppc_code->resolved_sym = ppc->symtree->n.sym;
5119 /* Although '_copy' is set to be elemental in class.c, it is
5120 not staying that way. Find out why, sometime.... */
5121 ppc_code->resolved_sym->attr.elemental = 1;
5122 ppc_code->ext.actual = actual;
5123 ppc_code->expr1 = ppc;
5124 ppc_code->op = EXEC_CALL;
5125 /* Since '_copy' is elemental, the scalarizer will take care
5126 of arrays in gfc_trans_call. */
5127 tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
5128 gfc_free_statements (ppc_code);
5130 else if (expr3 != NULL_TREE)
5132 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
5133 gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
5134 slen3, expr3, code->expr3->ts.kind);
5139 /* Switch off automatic reallocation since we have just done
5141 int realloc_lhs = gfc_option.flag_realloc_lhs;
5142 gfc_option.flag_realloc_lhs = 0;
5143 tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
5145 gfc_option.flag_realloc_lhs = realloc_lhs;
5147 gfc_free_expr (rhs);
5148 gfc_add_expr_to_block (&block, tmp);
5150 else if (code->expr3 && code->expr3->mold
5151 && code->expr3->ts.type == BT_CLASS)
5153 /* Since the _vptr has already been assigned to the allocate
5154 object, we can use gfc_copy_class_to_class in its
5155 initialization mode. */
5156 tmp = TREE_OPERAND (se.expr, 0);
5157 tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
5158 gfc_add_expr_to_block (&block, tmp);
5161 gfc_free_expr (expr);
5167 tmp = build1_v (LABEL_EXPR, label_errmsg);
5168 gfc_add_expr_to_block (&block, tmp);
5171 /* ERRMSG - only useful if STAT is present. */
5172 if (code->expr1 && code->expr2)
5174 const char *msg = "Attempt to allocate an allocated object";
5175 tree slen, dlen, errmsg_str;
5176 stmtblock_t errmsg_block;
5178 gfc_init_block (&errmsg_block);
5180 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
5181 gfc_add_modify (&errmsg_block, errmsg_str,
5182 gfc_build_addr_expr (pchar_type_node,
5183 gfc_build_localized_cstring_const (msg)));
5185 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5186 dlen = gfc_get_expr_charlen (code->expr2);
5187 slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
5190 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
5191 slen, errmsg_str, gfc_default_character_kind);
5192 dlen = gfc_finish_block (&errmsg_block);
5194 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5195 build_int_cst (TREE_TYPE (stat), 0));
5197 tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
5199 gfc_add_expr_to_block (&block, tmp);
5205 if (TREE_USED (label_finish))
5207 tmp = build1_v (LABEL_EXPR, label_finish);
5208 gfc_add_expr_to_block (&block, tmp);
5211 gfc_init_se (&se, NULL);
5212 gfc_conv_expr_lhs (&se, code->expr1);
5213 tmp = convert (TREE_TYPE (se.expr), stat);
5214 gfc_add_modify (&block, se.expr, tmp);
5217 gfc_add_block_to_block (&block, &se.post);
5218 gfc_add_block_to_block (&block, &post);
5220 return gfc_finish_block (&block);
5224 /* Translate a DEALLOCATE statement. */
5227 gfc_trans_deallocate (gfc_code *code)
5231 tree apstat, pstat, stat, errmsg, errlen, tmp;
5232 tree label_finish, label_errmsg;
5235 pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
5236 label_finish = label_errmsg = NULL_TREE;
5238 gfc_start_block (&block);
5240 /* Count the number of failed deallocations. If deallocate() was
5241 called with STAT= , then set STAT to the count. If deallocate
5242 was called with ERRMSG, then set ERRMG to a string. */
5245 tree gfc_int4_type_node = gfc_get_int_type (4);
5247 stat = gfc_create_var (gfc_int4_type_node, "stat");
5248 pstat = gfc_build_addr_expr (NULL_TREE, stat);
5250 /* GOTO destinations. */
5251 label_errmsg = gfc_build_label_decl (NULL_TREE);
5252 label_finish = gfc_build_label_decl (NULL_TREE);
5253 TREE_USED (label_finish) = 0;
5256 /* Set ERRMSG - only needed if STAT is available. */
5257 if (code->expr1 && code->expr2)
5259 gfc_init_se (&se, NULL);
5260 se.want_pointer = 1;
5261 gfc_conv_expr_lhs (&se, code->expr2);
5263 errlen = se.string_length;
5266 for (al = code->ext.alloc.list; al != NULL; al = al->next)
5268 gfc_expr *expr = gfc_copy_expr (al->expr);
5269 gcc_assert (expr->expr_type == EXPR_VARIABLE);
5271 if (expr->ts.type == BT_CLASS)
5272 gfc_add_data_component (expr);
5274 gfc_init_se (&se, NULL);
5275 gfc_start_block (&se.pre);
5277 se.want_pointer = 1;
5278 se.descriptor_only = 1;
5279 gfc_conv_expr (&se, expr);
5281 if (expr->rank || gfc_is_coarray (expr))
5283 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
5286 gfc_ref *last = NULL;
5287 for (ref = expr->ref; ref; ref = ref->next)
5288 if (ref->type == REF_COMPONENT)
5291 /* Do not deallocate the components of a derived type
5292 ultimate pointer component. */
5293 if (!(last && last->u.c.component->attr.pointer)
5294 && !(!last && expr->symtree->n.sym->attr.pointer))
5296 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
5298 gfc_add_expr_to_block (&se.pre, tmp);
5301 tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
5302 label_finish, expr);
5303 gfc_add_expr_to_block (&se.pre, tmp);
5307 tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
5309 gfc_add_expr_to_block (&se.pre, tmp);
5311 /* Set to zero after deallocation. */
5312 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5314 build_int_cst (TREE_TYPE (se.expr), 0));
5315 gfc_add_expr_to_block (&se.pre, tmp);
5317 if (al->expr->ts.type == BT_CLASS)
5319 /* Reset _vptr component to declared type. */
5320 gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
5321 gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
5322 gfc_add_vptr_component (lhs);
5323 rhs = gfc_lval_expr_from_sym (vtab);
5324 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5325 gfc_add_expr_to_block (&se.pre, tmp);
5326 gfc_free_expr (lhs);
5327 gfc_free_expr (rhs);
5335 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5336 build_int_cst (TREE_TYPE (stat), 0));
5337 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5338 gfc_unlikely (cond),
5339 build1_v (GOTO_EXPR, label_errmsg),
5340 build_empty_stmt (input_location));
5341 gfc_add_expr_to_block (&se.pre, tmp);
5344 tmp = gfc_finish_block (&se.pre);
5345 gfc_add_expr_to_block (&block, tmp);
5346 gfc_free_expr (expr);
5351 tmp = build1_v (LABEL_EXPR, label_errmsg);
5352 gfc_add_expr_to_block (&block, tmp);
5355 /* Set ERRMSG - only needed if STAT is available. */
5356 if (code->expr1 && code->expr2)
5358 const char *msg = "Attempt to deallocate an unallocated object";
5359 stmtblock_t errmsg_block;
5360 tree errmsg_str, slen, dlen, cond;
5362 gfc_init_block (&errmsg_block);
5364 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
5365 gfc_add_modify (&errmsg_block, errmsg_str,
5366 gfc_build_addr_expr (pchar_type_node,
5367 gfc_build_localized_cstring_const (msg)));
5368 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5369 dlen = gfc_get_expr_charlen (code->expr2);
5371 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
5372 slen, errmsg_str, gfc_default_character_kind);
5373 tmp = gfc_finish_block (&errmsg_block);
5375 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5376 build_int_cst (TREE_TYPE (stat), 0));
5377 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5378 gfc_unlikely (cond), tmp,
5379 build_empty_stmt (input_location));
5381 gfc_add_expr_to_block (&block, tmp);
5384 if (code->expr1 && TREE_USED (label_finish))
5386 tmp = build1_v (LABEL_EXPR, label_finish);
5387 gfc_add_expr_to_block (&block, tmp);
5393 gfc_init_se (&se, NULL);
5394 gfc_conv_expr_lhs (&se, code->expr1);
5395 tmp = convert (TREE_TYPE (se.expr), stat);
5396 gfc_add_modify (&block, se.expr, tmp);
5399 return gfc_finish_block (&block);
5402 #include "gt-fortran-trans-stmt.h"