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 gfc_conv_expr (&se, e);
1180 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
1181 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
1183 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
1185 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1186 gfc_finish_block (&se.post));
1189 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1190 else if (gfc_is_associate_pointer (sym))
1194 gcc_assert (!sym->attr.dimension);
1196 gfc_init_se (&se, NULL);
1197 gfc_conv_expr (&se, e);
1199 tmp = TREE_TYPE (sym->backend_decl);
1200 tmp = gfc_build_addr_expr (tmp, se.expr);
1201 gfc_add_modify (&se.pre, sym->backend_decl, tmp);
1203 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1204 gfc_finish_block (&se.post));
1207 /* Do a simple assignment. This is for scalar expressions, where we
1208 can simply use expression assignment. */
1213 lhs = gfc_lval_expr_from_sym (sym);
1214 tmp = gfc_trans_assignment (lhs, e, false, true);
1215 gfc_add_init_cleanup (block, tmp, NULL_TREE);
1220 /* Translate a BLOCK construct. This is basically what we would do for a
1224 gfc_trans_block_construct (gfc_code* code)
1228 gfc_wrapped_block block;
1231 gfc_association_list *ass;
1233 ns = code->ext.block.ns;
1235 sym = ns->proc_name;
1238 /* Process local variables. */
1239 gcc_assert (!sym->tlink);
1241 gfc_process_block_locals (ns);
1243 /* Generate code including exit-label. */
1244 gfc_init_block (&body);
1245 exit_label = gfc_build_label_decl (NULL_TREE);
1246 code->exit_label = exit_label;
1247 gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
1248 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1250 /* Finish everything. */
1251 gfc_start_wrapped_block (&block, gfc_finish_block (&body));
1252 gfc_trans_deferred_vars (sym, &block);
1253 for (ass = code->ext.block.assoc; ass; ass = ass->next)
1254 trans_associate_var (ass->st->n.sym, &block);
1256 return gfc_finish_wrapped_block (&block);
1260 /* Translate the simple DO construct. This is where the loop variable has
1261 integer type and step +-1. We can't use this in the general case
1262 because integer overflow and floating point errors could give incorrect
1264 We translate a do loop from:
1266 DO dovar = from, to, step
1272 [Evaluate loop bounds and step]
1274 if ((step > 0) ? (dovar <= to) : (dovar => to))
1280 cond = (dovar == to);
1282 if (cond) goto end_label;
1287 This helps the optimizers by avoiding the extra induction variable
1288 used in the general case. */
1291 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
1292 tree from, tree to, tree step, tree exit_cond)
1298 tree saved_dovar = NULL;
1303 type = TREE_TYPE (dovar);
1305 loc = code->ext.iterator->start->where.lb->location;
1307 /* Initialize the DO variable: dovar = from. */
1308 gfc_add_modify_loc (loc, pblock, dovar,
1309 fold_convert (TREE_TYPE(dovar), from));
1311 /* Save value for do-tinkering checking. */
1312 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1314 saved_dovar = gfc_create_var (type, ".saved_dovar");
1315 gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
1318 /* Cycle and exit statements are implemented with gotos. */
1319 cycle_label = gfc_build_label_decl (NULL_TREE);
1320 exit_label = gfc_build_label_decl (NULL_TREE);
1322 /* Put the labels where they can be found later. See gfc_trans_do(). */
1323 code->cycle_label = cycle_label;
1324 code->exit_label = exit_label;
1327 gfc_start_block (&body);
1329 /* Main loop body. */
1330 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1331 gfc_add_expr_to_block (&body, tmp);
1333 /* Label for cycle statements (if needed). */
1334 if (TREE_USED (cycle_label))
1336 tmp = build1_v (LABEL_EXPR, cycle_label);
1337 gfc_add_expr_to_block (&body, tmp);
1340 /* Check whether someone has modified the loop variable. */
1341 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1343 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
1344 dovar, saved_dovar);
1345 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1346 "Loop variable has been modified");
1349 /* Exit the loop if there is an I/O result condition or error. */
1352 tmp = build1_v (GOTO_EXPR, exit_label);
1353 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1355 build_empty_stmt (loc));
1356 gfc_add_expr_to_block (&body, tmp);
1359 /* Evaluate the loop condition. */
1360 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
1362 cond = gfc_evaluate_now_loc (loc, cond, &body);
1364 /* Increment the loop variable. */
1365 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1366 gfc_add_modify_loc (loc, &body, dovar, tmp);
1368 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1369 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1371 /* The loop exit. */
1372 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1373 TREE_USED (exit_label) = 1;
1374 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1375 cond, tmp, build_empty_stmt (loc));
1376 gfc_add_expr_to_block (&body, tmp);
1378 /* Finish the loop body. */
1379 tmp = gfc_finish_block (&body);
1380 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1382 /* Only execute the loop if the number of iterations is positive. */
1383 if (tree_int_cst_sgn (step) > 0)
1384 cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
1387 cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
1389 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
1390 build_empty_stmt (loc));
1391 gfc_add_expr_to_block (pblock, tmp);
1393 /* Add the exit label. */
1394 tmp = build1_v (LABEL_EXPR, exit_label);
1395 gfc_add_expr_to_block (pblock, tmp);
1397 return gfc_finish_block (pblock);
1400 /* Translate the DO construct. This obviously is one of the most
1401 important ones to get right with any compiler, but especially
1404 We special case some loop forms as described in gfc_trans_simple_do.
1405 For other cases we implement them with a separate loop count,
1406 as described in the standard.
1408 We translate a do loop from:
1410 DO dovar = from, to, step
1416 [evaluate loop bounds and step]
1417 empty = (step > 0 ? to < from : to > from);
1418 countm1 = (to - from) / step;
1420 if (empty) goto exit_label;
1426 if (countm1 ==0) goto exit_label;
1431 countm1 is an unsigned integer. It is equal to the loop count minus one,
1432 because the loop count itself can overflow. */
1435 gfc_trans_do (gfc_code * code, tree exit_cond)
1439 tree saved_dovar = NULL;
1455 gfc_start_block (&block);
1457 loc = code->ext.iterator->start->where.lb->location;
1459 /* Evaluate all the expressions in the iterator. */
1460 gfc_init_se (&se, NULL);
1461 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1462 gfc_add_block_to_block (&block, &se.pre);
1464 type = TREE_TYPE (dovar);
1466 gfc_init_se (&se, NULL);
1467 gfc_conv_expr_val (&se, code->ext.iterator->start);
1468 gfc_add_block_to_block (&block, &se.pre);
1469 from = gfc_evaluate_now (se.expr, &block);
1471 gfc_init_se (&se, NULL);
1472 gfc_conv_expr_val (&se, code->ext.iterator->end);
1473 gfc_add_block_to_block (&block, &se.pre);
1474 to = gfc_evaluate_now (se.expr, &block);
1476 gfc_init_se (&se, NULL);
1477 gfc_conv_expr_val (&se, code->ext.iterator->step);
1478 gfc_add_block_to_block (&block, &se.pre);
1479 step = gfc_evaluate_now (se.expr, &block);
1481 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1483 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
1484 build_zero_cst (type));
1485 gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
1486 "DO step value is zero");
1489 /* Special case simple loops. */
1490 if (TREE_CODE (type) == INTEGER_TYPE
1491 && (integer_onep (step)
1492 || tree_int_cst_equal (step, integer_minus_one_node)))
1493 return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
1495 pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
1496 build_zero_cst (type));
1498 if (TREE_CODE (type) == INTEGER_TYPE)
1499 utype = unsigned_type_for (type);
1501 utype = unsigned_type_for (gfc_array_index_type);
1502 countm1 = gfc_create_var (utype, "countm1");
1504 /* Cycle and exit statements are implemented with gotos. */
1505 cycle_label = gfc_build_label_decl (NULL_TREE);
1506 exit_label = gfc_build_label_decl (NULL_TREE);
1507 TREE_USED (exit_label) = 1;
1509 /* Put these labels where they can be found later. */
1510 code->cycle_label = cycle_label;
1511 code->exit_label = exit_label;
1513 /* Initialize the DO variable: dovar = from. */
1514 gfc_add_modify (&block, dovar, from);
1516 /* Save value for do-tinkering checking. */
1517 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1519 saved_dovar = gfc_create_var (type, ".saved_dovar");
1520 gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
1523 /* Initialize loop count and jump to exit label if the loop is empty.
1524 This code is executed before we enter the loop body. We generate:
1525 step_sign = sign(1,step);
1536 countm1 = (to*step_sign - from*step_sign) / (step*step_sign);
1540 if (TREE_CODE (type) == INTEGER_TYPE)
1542 tree pos, neg, step_sign, to2, from2, step2;
1544 /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */
1546 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
1547 build_int_cst (TREE_TYPE (step), 0));
1548 step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
1549 build_int_cst (type, -1),
1550 build_int_cst (type, 1));
1552 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
1553 pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1554 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1556 build_empty_stmt (loc));
1558 tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to,
1560 neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1561 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1563 build_empty_stmt (loc));
1564 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1565 pos_step, pos, neg);
1567 gfc_add_expr_to_block (&block, tmp);
1569 /* Calculate the loop count. to-from can overflow, so
1570 we cast to unsigned. */
1572 to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to);
1573 from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from);
1574 step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step);
1575 step2 = fold_convert (utype, step2);
1576 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2);
1577 tmp = fold_convert (utype, tmp);
1578 tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2);
1579 tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp);
1580 gfc_add_expr_to_block (&block, tmp);
1584 /* TODO: We could use the same width as the real type.
1585 This would probably cause more problems that it solves
1586 when we implement "long double" types. */
1588 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
1589 tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
1590 tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
1591 gfc_add_modify (&block, countm1, tmp);
1593 /* We need a special check for empty loops:
1594 empty = (step > 0 ? to < from : to > from); */
1595 tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
1596 fold_build2_loc (loc, LT_EXPR,
1597 boolean_type_node, to, from),
1598 fold_build2_loc (loc, GT_EXPR,
1599 boolean_type_node, to, from));
1600 /* If the loop is empty, go directly to the exit label. */
1601 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1602 build1_v (GOTO_EXPR, exit_label),
1603 build_empty_stmt (input_location));
1604 gfc_add_expr_to_block (&block, tmp);
1608 gfc_start_block (&body);
1610 /* Main loop body. */
1611 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1612 gfc_add_expr_to_block (&body, tmp);
1614 /* Label for cycle statements (if needed). */
1615 if (TREE_USED (cycle_label))
1617 tmp = build1_v (LABEL_EXPR, cycle_label);
1618 gfc_add_expr_to_block (&body, tmp);
1621 /* Check whether someone has modified the loop variable. */
1622 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1624 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
1626 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1627 "Loop variable has been modified");
1630 /* Exit the loop if there is an I/O result condition or error. */
1633 tmp = build1_v (GOTO_EXPR, exit_label);
1634 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1636 build_empty_stmt (input_location));
1637 gfc_add_expr_to_block (&body, tmp);
1640 /* Increment the loop variable. */
1641 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1642 gfc_add_modify_loc (loc, &body, dovar, tmp);
1644 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1645 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1647 /* End with the loop condition. Loop until countm1 == 0. */
1648 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1,
1649 build_int_cst (utype, 0));
1650 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1651 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1652 cond, tmp, build_empty_stmt (loc));
1653 gfc_add_expr_to_block (&body, tmp);
1655 /* Decrement the loop count. */
1656 tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
1657 build_int_cst (utype, 1));
1658 gfc_add_modify_loc (loc, &body, countm1, tmp);
1660 /* End of loop body. */
1661 tmp = gfc_finish_block (&body);
1663 /* The for loop itself. */
1664 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1665 gfc_add_expr_to_block (&block, tmp);
1667 /* Add the exit label. */
1668 tmp = build1_v (LABEL_EXPR, exit_label);
1669 gfc_add_expr_to_block (&block, tmp);
1671 return gfc_finish_block (&block);
1675 /* Translate the DO WHILE construct.
1688 if (! cond) goto exit_label;
1694 Because the evaluation of the exit condition `cond' may have side
1695 effects, we can't do much for empty loop bodies. The backend optimizers
1696 should be smart enough to eliminate any dead loops. */
1699 gfc_trans_do_while (gfc_code * code)
1707 /* Everything we build here is part of the loop body. */
1708 gfc_start_block (&block);
1710 /* Cycle and exit statements are implemented with gotos. */
1711 cycle_label = gfc_build_label_decl (NULL_TREE);
1712 exit_label = gfc_build_label_decl (NULL_TREE);
1714 /* Put the labels where they can be found later. See gfc_trans_do(). */
1715 code->cycle_label = cycle_label;
1716 code->exit_label = exit_label;
1718 /* Create a GIMPLE version of the exit condition. */
1719 gfc_init_se (&cond, NULL);
1720 gfc_conv_expr_val (&cond, code->expr1);
1721 gfc_add_block_to_block (&block, &cond.pre);
1722 cond.expr = fold_build1_loc (code->expr1->where.lb->location,
1723 TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
1725 /* Build "IF (! cond) GOTO exit_label". */
1726 tmp = build1_v (GOTO_EXPR, exit_label);
1727 TREE_USED (exit_label) = 1;
1728 tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
1729 void_type_node, cond.expr, tmp,
1730 build_empty_stmt (code->expr1->where.lb->location));
1731 gfc_add_expr_to_block (&block, tmp);
1733 /* The main body of the loop. */
1734 tmp = gfc_trans_code (code->block->next);
1735 gfc_add_expr_to_block (&block, tmp);
1737 /* Label for cycle statements (if needed). */
1738 if (TREE_USED (cycle_label))
1740 tmp = build1_v (LABEL_EXPR, cycle_label);
1741 gfc_add_expr_to_block (&block, tmp);
1744 /* End of loop body. */
1745 tmp = gfc_finish_block (&block);
1747 gfc_init_block (&block);
1748 /* Build the loop. */
1749 tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
1750 void_type_node, tmp);
1751 gfc_add_expr_to_block (&block, tmp);
1753 /* Add the exit label. */
1754 tmp = build1_v (LABEL_EXPR, exit_label);
1755 gfc_add_expr_to_block (&block, tmp);
1757 return gfc_finish_block (&block);
1761 /* Translate the SELECT CASE construct for INTEGER case expressions,
1762 without killing all potential optimizations. The problem is that
1763 Fortran allows unbounded cases, but the back-end does not, so we
1764 need to intercept those before we enter the equivalent SWITCH_EXPR
1767 For example, we translate this,
1770 CASE (:100,101,105:115)
1780 to the GENERIC equivalent,
1784 case (minimum value for typeof(expr) ... 100:
1790 case 200 ... (maximum value for typeof(expr):
1807 gfc_trans_integer_select (gfc_code * code)
1817 gfc_start_block (&block);
1819 /* Calculate the switch expression. */
1820 gfc_init_se (&se, NULL);
1821 gfc_conv_expr_val (&se, code->expr1);
1822 gfc_add_block_to_block (&block, &se.pre);
1824 end_label = gfc_build_label_decl (NULL_TREE);
1826 gfc_init_block (&body);
1828 for (c = code->block; c; c = c->block)
1830 for (cp = c->ext.block.case_list; cp; cp = cp->next)
1835 /* Assume it's the default case. */
1836 low = high = NULL_TREE;
1840 low = gfc_conv_mpz_to_tree (cp->low->value.integer,
1843 /* If there's only a lower bound, set the high bound to the
1844 maximum value of the case expression. */
1846 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1851 /* Three cases are possible here:
1853 1) There is no lower bound, e.g. CASE (:N).
1854 2) There is a lower bound .NE. high bound, that is
1855 a case range, e.g. CASE (N:M) where M>N (we make
1856 sure that M>N during type resolution).
1857 3) There is a lower bound, and it has the same value
1858 as the high bound, e.g. CASE (N:N). This is our
1859 internal representation of CASE(N).
1861 In the first and second case, we need to set a value for
1862 high. In the third case, we don't because the GCC middle
1863 end represents a single case value by just letting high be
1864 a NULL_TREE. We can't do that because we need to be able
1865 to represent unbounded cases. */
1869 && mpz_cmp (cp->low->value.integer,
1870 cp->high->value.integer) != 0))
1871 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
1874 /* Unbounded case. */
1876 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1879 /* Build a label. */
1880 label = gfc_build_label_decl (NULL_TREE);
1882 /* Add this case label.
1883 Add parameter 'label', make it match GCC backend. */
1884 tmp = build_case_label (low, high, label);
1885 gfc_add_expr_to_block (&body, tmp);
1888 /* Add the statements for this case. */
1889 tmp = gfc_trans_code (c->next);
1890 gfc_add_expr_to_block (&body, tmp);
1892 /* Break to the end of the construct. */
1893 tmp = build1_v (GOTO_EXPR, end_label);
1894 gfc_add_expr_to_block (&body, tmp);
1897 tmp = gfc_finish_block (&body);
1898 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1899 gfc_add_expr_to_block (&block, tmp);
1901 tmp = build1_v (LABEL_EXPR, end_label);
1902 gfc_add_expr_to_block (&block, tmp);
1904 return gfc_finish_block (&block);
1908 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1910 There are only two cases possible here, even though the standard
1911 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1912 .FALSE., and DEFAULT.
1914 We never generate more than two blocks here. Instead, we always
1915 try to eliminate the DEFAULT case. This way, we can translate this
1916 kind of SELECT construct to a simple
1920 expression in GENERIC. */
1923 gfc_trans_logical_select (gfc_code * code)
1926 gfc_code *t, *f, *d;
1931 /* Assume we don't have any cases at all. */
1934 /* Now see which ones we actually do have. We can have at most two
1935 cases in a single case list: one for .TRUE. and one for .FALSE.
1936 The default case is always separate. If the cases for .TRUE. and
1937 .FALSE. are in the same case list, the block for that case list
1938 always executed, and we don't generate code a COND_EXPR. */
1939 for (c = code->block; c; c = c->block)
1941 for (cp = c->ext.block.case_list; cp; cp = cp->next)
1945 if (cp->low->value.logical == 0) /* .FALSE. */
1947 else /* if (cp->value.logical != 0), thus .TRUE. */
1955 /* Start a new block. */
1956 gfc_start_block (&block);
1958 /* Calculate the switch expression. We always need to do this
1959 because it may have side effects. */
1960 gfc_init_se (&se, NULL);
1961 gfc_conv_expr_val (&se, code->expr1);
1962 gfc_add_block_to_block (&block, &se.pre);
1964 if (t == f && t != NULL)
1966 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1967 translate the code for these cases, append it to the current
1969 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1973 tree true_tree, false_tree, stmt;
1975 true_tree = build_empty_stmt (input_location);
1976 false_tree = build_empty_stmt (input_location);
1978 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1979 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1980 make the missing case the default case. */
1981 if (t != NULL && f != NULL)
1991 /* Translate the code for each of these blocks, and append it to
1992 the current block. */
1994 true_tree = gfc_trans_code (t->next);
1997 false_tree = gfc_trans_code (f->next);
1999 stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2000 se.expr, true_tree, false_tree);
2001 gfc_add_expr_to_block (&block, stmt);
2004 return gfc_finish_block (&block);
2008 /* The jump table types are stored in static variables to avoid
2009 constructing them from scratch every single time. */
2010 static GTY(()) tree select_struct[2];
2012 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2013 Instead of generating compares and jumps, it is far simpler to
2014 generate a data structure describing the cases in order and call a
2015 library subroutine that locates the right case.
2016 This is particularly true because this is the only case where we
2017 might have to dispose of a temporary.
2018 The library subroutine returns a pointer to jump to or NULL if no
2019 branches are to be taken. */
2022 gfc_trans_character_select (gfc_code *code)
2024 tree init, end_label, tmp, type, case_num, label, fndecl;
2025 stmtblock_t block, body;
2030 VEC(constructor_elt,gc) *inits = NULL;
2032 tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
2034 /* The jump table types are stored in static variables to avoid
2035 constructing them from scratch every single time. */
2036 static tree ss_string1[2], ss_string1_len[2];
2037 static tree ss_string2[2], ss_string2_len[2];
2038 static tree ss_target[2];
2040 cp = code->block->ext.block.case_list;
2041 while (cp->left != NULL)
2044 /* Generate the body */
2045 gfc_start_block (&block);
2046 gfc_init_se (&expr1se, NULL);
2047 gfc_conv_expr_reference (&expr1se, code->expr1);
2049 gfc_add_block_to_block (&block, &expr1se.pre);
2051 end_label = gfc_build_label_decl (NULL_TREE);
2053 gfc_init_block (&body);
2055 /* Attempt to optimize length 1 selects. */
2056 if (integer_onep (expr1se.string_length))
2058 for (d = cp; d; d = d->right)
2063 gcc_assert (d->low->expr_type == EXPR_CONSTANT
2064 && d->low->ts.type == BT_CHARACTER);
2065 if (d->low->value.character.length > 1)
2067 for (i = 1; i < d->low->value.character.length; i++)
2068 if (d->low->value.character.string[i] != ' ')
2070 if (i != d->low->value.character.length)
2072 if (optimize && d->high && i == 1)
2074 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2075 && d->high->ts.type == BT_CHARACTER);
2076 if (d->high->value.character.length > 1
2077 && (d->low->value.character.string[0]
2078 == d->high->value.character.string[0])
2079 && d->high->value.character.string[1] != ' '
2080 && ((d->low->value.character.string[1] < ' ')
2081 == (d->high->value.character.string[1]
2091 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2092 && d->high->ts.type == BT_CHARACTER);
2093 if (d->high->value.character.length > 1)
2095 for (i = 1; i < d->high->value.character.length; i++)
2096 if (d->high->value.character.string[i] != ' ')
2098 if (i != d->high->value.character.length)
2105 tree ctype = gfc_get_char_type (code->expr1->ts.kind);
2107 for (c = code->block; c; c = c->block)
2109 for (cp = c->ext.block.case_list; cp; cp = cp->next)
2115 /* Assume it's the default case. */
2116 low = high = NULL_TREE;
2120 /* CASE ('ab') or CASE ('ab':'az') will never match
2121 any length 1 character. */
2122 if (cp->low->value.character.length > 1
2123 && cp->low->value.character.string[1] != ' ')
2126 if (cp->low->value.character.length > 0)
2127 r = cp->low->value.character.string[0];
2130 low = build_int_cst (ctype, r);
2132 /* If there's only a lower bound, set the high bound
2133 to the maximum value of the case expression. */
2135 high = TYPE_MAX_VALUE (ctype);
2141 || (cp->low->value.character.string[0]
2142 != cp->high->value.character.string[0]))
2144 if (cp->high->value.character.length > 0)
2145 r = cp->high->value.character.string[0];
2148 high = build_int_cst (ctype, r);
2151 /* Unbounded case. */
2153 low = TYPE_MIN_VALUE (ctype);
2156 /* Build a label. */
2157 label = gfc_build_label_decl (NULL_TREE);
2159 /* Add this case label.
2160 Add parameter 'label', make it match GCC backend. */
2161 tmp = build_case_label (low, high, label);
2162 gfc_add_expr_to_block (&body, tmp);
2165 /* Add the statements for this case. */
2166 tmp = gfc_trans_code (c->next);
2167 gfc_add_expr_to_block (&body, tmp);
2169 /* Break to the end of the construct. */
2170 tmp = build1_v (GOTO_EXPR, end_label);
2171 gfc_add_expr_to_block (&body, tmp);
2174 tmp = gfc_string_to_single_character (expr1se.string_length,
2176 code->expr1->ts.kind);
2177 case_num = gfc_create_var (ctype, "case_num");
2178 gfc_add_modify (&block, case_num, tmp);
2180 gfc_add_block_to_block (&block, &expr1se.post);
2182 tmp = gfc_finish_block (&body);
2183 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2184 gfc_add_expr_to_block (&block, tmp);
2186 tmp = build1_v (LABEL_EXPR, end_label);
2187 gfc_add_expr_to_block (&block, tmp);
2189 return gfc_finish_block (&block);
2193 if (code->expr1->ts.kind == 1)
2195 else if (code->expr1->ts.kind == 4)
2200 if (select_struct[k] == NULL)
2203 select_struct[k] = make_node (RECORD_TYPE);
2205 if (code->expr1->ts.kind == 1)
2206 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
2207 else if (code->expr1->ts.kind == 4)
2208 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
2213 #define ADD_FIELD(NAME, TYPE) \
2214 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2215 get_identifier (stringize(NAME)), \
2219 ADD_FIELD (string1, pchartype);
2220 ADD_FIELD (string1_len, gfc_charlen_type_node);
2222 ADD_FIELD (string2, pchartype);
2223 ADD_FIELD (string2_len, gfc_charlen_type_node);
2225 ADD_FIELD (target, integer_type_node);
2228 gfc_finish_type (select_struct[k]);
2232 for (d = cp; d; d = d->right)
2235 for (c = code->block; c; c = c->block)
2237 for (d = c->ext.block.case_list; d; d = d->next)
2239 label = gfc_build_label_decl (NULL_TREE);
2240 tmp = build_case_label ((d->low == NULL && d->high == NULL)
2242 : build_int_cst (integer_type_node, d->n),
2244 gfc_add_expr_to_block (&body, tmp);
2247 tmp = gfc_trans_code (c->next);
2248 gfc_add_expr_to_block (&body, tmp);
2250 tmp = build1_v (GOTO_EXPR, end_label);
2251 gfc_add_expr_to_block (&body, tmp);
2254 /* Generate the structure describing the branches */
2255 for (d = cp; d; d = d->right)
2257 VEC(constructor_elt,gc) *node = NULL;
2259 gfc_init_se (&se, NULL);
2263 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
2264 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
2268 gfc_conv_expr_reference (&se, d->low);
2270 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
2271 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
2274 if (d->high == NULL)
2276 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
2277 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
2281 gfc_init_se (&se, NULL);
2282 gfc_conv_expr_reference (&se, d->high);
2284 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
2285 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
2288 CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
2289 build_int_cst (integer_type_node, d->n));
2291 tmp = build_constructor (select_struct[k], node);
2292 CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
2295 type = build_array_type (select_struct[k],
2296 build_index_type (size_int (n-1)));
2298 init = build_constructor (type, inits);
2299 TREE_CONSTANT (init) = 1;
2300 TREE_STATIC (init) = 1;
2301 /* Create a static variable to hold the jump table. */
2302 tmp = gfc_create_var (type, "jumptable");
2303 TREE_CONSTANT (tmp) = 1;
2304 TREE_STATIC (tmp) = 1;
2305 TREE_READONLY (tmp) = 1;
2306 DECL_INITIAL (tmp) = init;
2309 /* Build the library call */
2310 init = gfc_build_addr_expr (pvoid_type_node, init);
2312 if (code->expr1->ts.kind == 1)
2313 fndecl = gfor_fndecl_select_string;
2314 else if (code->expr1->ts.kind == 4)
2315 fndecl = gfor_fndecl_select_string_char4;
2319 tmp = build_call_expr_loc (input_location,
2321 build_int_cst (gfc_charlen_type_node, n),
2322 expr1se.expr, expr1se.string_length);
2323 case_num = gfc_create_var (integer_type_node, "case_num");
2324 gfc_add_modify (&block, case_num, tmp);
2326 gfc_add_block_to_block (&block, &expr1se.post);
2328 tmp = gfc_finish_block (&body);
2329 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2330 gfc_add_expr_to_block (&block, tmp);
2332 tmp = build1_v (LABEL_EXPR, end_label);
2333 gfc_add_expr_to_block (&block, tmp);
2335 return gfc_finish_block (&block);
2339 /* Translate the three variants of the SELECT CASE construct.
2341 SELECT CASEs with INTEGER case expressions can be translated to an
2342 equivalent GENERIC switch statement, and for LOGICAL case
2343 expressions we build one or two if-else compares.
2345 SELECT CASEs with CHARACTER case expressions are a whole different
2346 story, because they don't exist in GENERIC. So we sort them and
2347 do a binary search at runtime.
2349 Fortran has no BREAK statement, and it does not allow jumps from
2350 one case block to another. That makes things a lot easier for
2354 gfc_trans_select (gfc_code * code)
2360 gcc_assert (code && code->expr1);
2361 gfc_init_block (&block);
2363 /* Build the exit label and hang it in. */
2364 exit_label = gfc_build_label_decl (NULL_TREE);
2365 code->exit_label = exit_label;
2367 /* Empty SELECT constructs are legal. */
2368 if (code->block == NULL)
2369 body = build_empty_stmt (input_location);
2371 /* Select the correct translation function. */
2373 switch (code->expr1->ts.type)
2376 body = gfc_trans_logical_select (code);
2380 body = gfc_trans_integer_select (code);
2384 body = gfc_trans_character_select (code);
2388 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2392 /* Build everything together. */
2393 gfc_add_expr_to_block (&block, body);
2394 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
2396 return gfc_finish_block (&block);
2400 /* Traversal function to substitute a replacement symtree if the symbol
2401 in the expression is the same as that passed. f == 2 signals that
2402 that variable itself is not to be checked - only the references.
2403 This group of functions is used when the variable expression in a
2404 FORALL assignment has internal references. For example:
2405 FORALL (i = 1:4) p(p(i)) = i
2406 The only recourse here is to store a copy of 'p' for the index
2409 static gfc_symtree *new_symtree;
2410 static gfc_symtree *old_symtree;
2413 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
2415 if (expr->expr_type != EXPR_VARIABLE)
2420 else if (expr->symtree->n.sym == sym)
2421 expr->symtree = new_symtree;
2427 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
2429 gfc_traverse_expr (e, sym, forall_replace, f);
2433 forall_restore (gfc_expr *expr,
2434 gfc_symbol *sym ATTRIBUTE_UNUSED,
2435 int *f ATTRIBUTE_UNUSED)
2437 if (expr->expr_type != EXPR_VARIABLE)
2440 if (expr->symtree == new_symtree)
2441 expr->symtree = old_symtree;
2447 forall_restore_symtree (gfc_expr *e)
2449 gfc_traverse_expr (e, NULL, forall_restore, 0);
2453 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2458 gfc_symbol *new_sym;
2459 gfc_symbol *old_sym;
2463 /* Build a copy of the lvalue. */
2464 old_symtree = c->expr1->symtree;
2465 old_sym = old_symtree->n.sym;
2466 e = gfc_lval_expr_from_sym (old_sym);
2467 if (old_sym->attr.dimension)
2469 gfc_init_se (&tse, NULL);
2470 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
2471 gfc_add_block_to_block (pre, &tse.pre);
2472 gfc_add_block_to_block (post, &tse.post);
2473 tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
2475 if (e->ts.type != BT_CHARACTER)
2477 /* Use the variable offset for the temporary. */
2478 tmp = gfc_conv_array_offset (old_sym->backend_decl);
2479 gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
2484 gfc_init_se (&tse, NULL);
2485 gfc_init_se (&rse, NULL);
2486 gfc_conv_expr (&rse, e);
2487 if (e->ts.type == BT_CHARACTER)
2489 tse.string_length = rse.string_length;
2490 tmp = gfc_get_character_type_len (gfc_default_character_kind,
2492 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
2494 gfc_add_block_to_block (pre, &tse.pre);
2495 gfc_add_block_to_block (post, &tse.post);
2499 tmp = gfc_typenode_for_spec (&e->ts);
2500 tse.expr = gfc_create_var (tmp, "temp");
2503 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
2504 e->expr_type == EXPR_VARIABLE, true);
2505 gfc_add_expr_to_block (pre, tmp);
2509 /* Create a new symbol to represent the lvalue. */
2510 new_sym = gfc_new_symbol (old_sym->name, NULL);
2511 new_sym->ts = old_sym->ts;
2512 new_sym->attr.referenced = 1;
2513 new_sym->attr.temporary = 1;
2514 new_sym->attr.dimension = old_sym->attr.dimension;
2515 new_sym->attr.flavor = old_sym->attr.flavor;
2517 /* Use the temporary as the backend_decl. */
2518 new_sym->backend_decl = tse.expr;
2520 /* Create a fake symtree for it. */
2522 new_symtree = gfc_new_symtree (&root, old_sym->name);
2523 new_symtree->n.sym = new_sym;
2524 gcc_assert (new_symtree == root);
2526 /* Go through the expression reference replacing the old_symtree
2528 forall_replace_symtree (c->expr1, old_sym, 2);
2530 /* Now we have made this temporary, we might as well use it for
2531 the right hand side. */
2532 forall_replace_symtree (c->expr2, old_sym, 1);
2536 /* Handles dependencies in forall assignments. */
2538 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2545 lsym = c->expr1->symtree->n.sym;
2546 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
2548 /* Now check for dependencies within the 'variable'
2549 expression itself. These are treated by making a complete
2550 copy of variable and changing all the references to it
2551 point to the copy instead. Note that the shallow copy of
2552 the variable will not suffice for derived types with
2553 pointer components. We therefore leave these to their
2555 if (lsym->ts.type == BT_DERIVED
2556 && lsym->ts.u.derived->attr.pointer_comp)
2560 if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
2562 forall_make_variable_temp (c, pre, post);
2566 /* Substrings with dependencies are treated in the same
2568 if (c->expr1->ts.type == BT_CHARACTER
2570 && c->expr2->expr_type == EXPR_VARIABLE
2571 && lsym == c->expr2->symtree->n.sym)
2573 for (lref = c->expr1->ref; lref; lref = lref->next)
2574 if (lref->type == REF_SUBSTRING)
2576 for (rref = c->expr2->ref; rref; rref = rref->next)
2577 if (rref->type == REF_SUBSTRING)
2581 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
2583 forall_make_variable_temp (c, pre, post);
2592 cleanup_forall_symtrees (gfc_code *c)
2594 forall_restore_symtree (c->expr1);
2595 forall_restore_symtree (c->expr2);
2596 free (new_symtree->n.sym);
2601 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
2602 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
2603 indicates whether we should generate code to test the FORALLs mask
2604 array. OUTER is the loop header to be used for initializing mask
2607 The generated loop format is:
2608 count = (end - start + step) / step
2621 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
2622 int mask_flag, stmtblock_t *outer)
2630 tree var, start, end, step;
2633 /* Initialize the mask index outside the FORALL nest. */
2634 if (mask_flag && forall_tmp->mask)
2635 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
2637 iter = forall_tmp->this_loop;
2638 nvar = forall_tmp->nvar;
2639 for (n = 0; n < nvar; n++)
2642 start = iter->start;
2646 exit_label = gfc_build_label_decl (NULL_TREE);
2647 TREE_USED (exit_label) = 1;
2649 /* The loop counter. */
2650 count = gfc_create_var (TREE_TYPE (var), "count");
2652 /* The body of the loop. */
2653 gfc_init_block (&block);
2655 /* The exit condition. */
2656 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
2657 count, build_int_cst (TREE_TYPE (count), 0));
2658 tmp = build1_v (GOTO_EXPR, exit_label);
2659 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2660 cond, tmp, build_empty_stmt (input_location));
2661 gfc_add_expr_to_block (&block, tmp);
2663 /* The main loop body. */
2664 gfc_add_expr_to_block (&block, body);
2666 /* Increment the loop variable. */
2667 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
2669 gfc_add_modify (&block, var, tmp);
2671 /* Advance to the next mask element. Only do this for the
2673 if (n == 0 && mask_flag && forall_tmp->mask)
2675 tree maskindex = forall_tmp->maskindex;
2676 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2677 maskindex, gfc_index_one_node);
2678 gfc_add_modify (&block, maskindex, tmp);
2681 /* Decrement the loop counter. */
2682 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
2683 build_int_cst (TREE_TYPE (var), 1));
2684 gfc_add_modify (&block, count, tmp);
2686 body = gfc_finish_block (&block);
2688 /* Loop var initialization. */
2689 gfc_init_block (&block);
2690 gfc_add_modify (&block, var, start);
2693 /* Initialize the loop counter. */
2694 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
2696 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
2698 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
2700 gfc_add_modify (&block, count, tmp);
2702 /* The loop expression. */
2703 tmp = build1_v (LOOP_EXPR, body);
2704 gfc_add_expr_to_block (&block, tmp);
2706 /* The exit label. */
2707 tmp = build1_v (LABEL_EXPR, exit_label);
2708 gfc_add_expr_to_block (&block, tmp);
2710 body = gfc_finish_block (&block);
2717 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
2718 is nonzero, the body is controlled by all masks in the forall nest.
2719 Otherwise, the innermost loop is not controlled by it's mask. This
2720 is used for initializing that mask. */
2723 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
2728 forall_info *forall_tmp;
2729 tree mask, maskindex;
2731 gfc_start_block (&header);
2733 forall_tmp = nested_forall_info;
2734 while (forall_tmp != NULL)
2736 /* Generate body with masks' control. */
2739 mask = forall_tmp->mask;
2740 maskindex = forall_tmp->maskindex;
2742 /* If a mask was specified make the assignment conditional. */
2745 tmp = gfc_build_array_ref (mask, maskindex, NULL);
2746 body = build3_v (COND_EXPR, tmp, body,
2747 build_empty_stmt (input_location));
2750 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
2751 forall_tmp = forall_tmp->prev_nest;
2755 gfc_add_expr_to_block (&header, body);
2756 return gfc_finish_block (&header);
2760 /* Allocate data for holding a temporary array. Returns either a local
2761 temporary array or a pointer variable. */
2764 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
2771 if (INTEGER_CST_P (size))
2772 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2773 size, gfc_index_one_node);
2777 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
2778 type = build_array_type (elem_type, type);
2779 if (gfc_can_put_var_on_stack (bytesize))
2781 gcc_assert (INTEGER_CST_P (size));
2782 tmpvar = gfc_create_var (type, "temp");
2787 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
2788 *pdata = convert (pvoid_type_node, tmpvar);
2790 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
2791 gfc_add_modify (pblock, tmpvar, tmp);
2797 /* Generate codes to copy the temporary to the actual lhs. */
2800 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
2801 tree count1, tree wheremask, bool invert)
2805 stmtblock_t block, body;
2811 lss = gfc_walk_expr (expr);
2813 if (lss == gfc_ss_terminator)
2815 gfc_start_block (&block);
2817 gfc_init_se (&lse, NULL);
2819 /* Translate the expression. */
2820 gfc_conv_expr (&lse, expr);
2822 /* Form the expression for the temporary. */
2823 tmp = gfc_build_array_ref (tmp1, count1, NULL);
2825 /* Use the scalar assignment as is. */
2826 gfc_add_block_to_block (&block, &lse.pre);
2827 gfc_add_modify (&block, lse.expr, tmp);
2828 gfc_add_block_to_block (&block, &lse.post);
2830 /* Increment the count1. */
2831 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2832 count1, gfc_index_one_node);
2833 gfc_add_modify (&block, count1, tmp);
2835 tmp = gfc_finish_block (&block);
2839 gfc_start_block (&block);
2841 gfc_init_loopinfo (&loop1);
2842 gfc_init_se (&rse, NULL);
2843 gfc_init_se (&lse, NULL);
2845 /* Associate the lss with the loop. */
2846 gfc_add_ss_to_loop (&loop1, lss);
2848 /* Calculate the bounds of the scalarization. */
2849 gfc_conv_ss_startstride (&loop1);
2850 /* Setup the scalarizing loops. */
2851 gfc_conv_loop_setup (&loop1, &expr->where);
2853 gfc_mark_ss_chain_used (lss, 1);
2855 /* Start the scalarized loop body. */
2856 gfc_start_scalarized_body (&loop1, &body);
2858 /* Setup the gfc_se structures. */
2859 gfc_copy_loopinfo_to_se (&lse, &loop1);
2862 /* Form the expression of the temporary. */
2863 if (lss != gfc_ss_terminator)
2864 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2865 /* Translate expr. */
2866 gfc_conv_expr (&lse, expr);
2868 /* Use the scalar assignment. */
2869 rse.string_length = lse.string_length;
2870 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
2872 /* Form the mask expression according to the mask tree list. */
2875 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2877 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2878 TREE_TYPE (wheremaskexpr),
2880 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2882 build_empty_stmt (input_location));
2885 gfc_add_expr_to_block (&body, tmp);
2887 /* Increment count1. */
2888 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2889 count1, gfc_index_one_node);
2890 gfc_add_modify (&body, count1, tmp);
2892 /* Increment count3. */
2895 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2896 gfc_array_index_type, count3,
2897 gfc_index_one_node);
2898 gfc_add_modify (&body, count3, tmp);
2901 /* Generate the copying loops. */
2902 gfc_trans_scalarizing_loops (&loop1, &body);
2903 gfc_add_block_to_block (&block, &loop1.pre);
2904 gfc_add_block_to_block (&block, &loop1.post);
2905 gfc_cleanup_loop (&loop1);
2907 tmp = gfc_finish_block (&block);
2913 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
2914 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
2915 and should not be freed. WHEREMASK is the conditional execution mask
2916 whose sense may be inverted by INVERT. */
2919 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
2920 tree count1, gfc_ss *lss, gfc_ss *rss,
2921 tree wheremask, bool invert)
2923 stmtblock_t block, body1;
2930 gfc_start_block (&block);
2932 gfc_init_se (&rse, NULL);
2933 gfc_init_se (&lse, NULL);
2935 if (lss == gfc_ss_terminator)
2937 gfc_init_block (&body1);
2938 gfc_conv_expr (&rse, expr2);
2939 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2943 /* Initialize the loop. */
2944 gfc_init_loopinfo (&loop);
2946 /* We may need LSS to determine the shape of the expression. */
2947 gfc_add_ss_to_loop (&loop, lss);
2948 gfc_add_ss_to_loop (&loop, rss);
2950 gfc_conv_ss_startstride (&loop);
2951 gfc_conv_loop_setup (&loop, &expr2->where);
2953 gfc_mark_ss_chain_used (rss, 1);
2954 /* Start the loop body. */
2955 gfc_start_scalarized_body (&loop, &body1);
2957 /* Translate the expression. */
2958 gfc_copy_loopinfo_to_se (&rse, &loop);
2960 gfc_conv_expr (&rse, expr2);
2962 /* Form the expression of the temporary. */
2963 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2966 /* Use the scalar assignment. */
2967 lse.string_length = rse.string_length;
2968 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
2969 expr2->expr_type == EXPR_VARIABLE, true);
2971 /* Form the mask expression according to the mask tree list. */
2974 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2976 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2977 TREE_TYPE (wheremaskexpr),
2979 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2981 build_empty_stmt (input_location));
2984 gfc_add_expr_to_block (&body1, tmp);
2986 if (lss == gfc_ss_terminator)
2988 gfc_add_block_to_block (&block, &body1);
2990 /* Increment count1. */
2991 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2992 count1, gfc_index_one_node);
2993 gfc_add_modify (&block, count1, tmp);
2997 /* Increment count1. */
2998 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2999 count1, gfc_index_one_node);
3000 gfc_add_modify (&body1, count1, tmp);
3002 /* Increment count3. */
3005 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3006 gfc_array_index_type,
3007 count3, gfc_index_one_node);
3008 gfc_add_modify (&body1, count3, tmp);
3011 /* Generate the copying loops. */
3012 gfc_trans_scalarizing_loops (&loop, &body1);
3014 gfc_add_block_to_block (&block, &loop.pre);
3015 gfc_add_block_to_block (&block, &loop.post);
3017 gfc_cleanup_loop (&loop);
3018 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3019 as tree nodes in SS may not be valid in different scope. */
3022 tmp = gfc_finish_block (&block);
3027 /* Calculate the size of temporary needed in the assignment inside forall.
3028 LSS and RSS are filled in this function. */
3031 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
3032 stmtblock_t * pblock,
3033 gfc_ss **lss, gfc_ss **rss)
3041 *lss = gfc_walk_expr (expr1);
3044 size = gfc_index_one_node;
3045 if (*lss != gfc_ss_terminator)
3047 gfc_init_loopinfo (&loop);
3049 /* Walk the RHS of the expression. */
3050 *rss = gfc_walk_expr (expr2);
3051 if (*rss == gfc_ss_terminator)
3052 /* The rhs is scalar. Add a ss for the expression. */
3053 *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
3055 /* Associate the SS with the loop. */
3056 gfc_add_ss_to_loop (&loop, *lss);
3057 /* We don't actually need to add the rhs at this point, but it might
3058 make guessing the loop bounds a bit easier. */
3059 gfc_add_ss_to_loop (&loop, *rss);
3061 /* We only want the shape of the expression, not rest of the junk
3062 generated by the scalarizer. */
3063 loop.array_parameter = 1;
3065 /* Calculate the bounds of the scalarization. */
3066 save_flag = gfc_option.rtcheck;
3067 gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
3068 gfc_conv_ss_startstride (&loop);
3069 gfc_option.rtcheck = save_flag;
3070 gfc_conv_loop_setup (&loop, &expr2->where);
3072 /* Figure out how many elements we need. */
3073 for (i = 0; i < loop.dimen; i++)
3075 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3076 gfc_array_index_type,
3077 gfc_index_one_node, loop.from[i]);
3078 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3079 gfc_array_index_type, tmp, loop.to[i]);
3080 size = fold_build2_loc (input_location, MULT_EXPR,
3081 gfc_array_index_type, size, tmp);
3083 gfc_add_block_to_block (pblock, &loop.pre);
3084 size = gfc_evaluate_now (size, pblock);
3085 gfc_add_block_to_block (pblock, &loop.post);
3087 /* TODO: write a function that cleans up a loopinfo without freeing
3088 the SS chains. Currently a NOP. */
3095 /* Calculate the overall iterator number of the nested forall construct.
3096 This routine actually calculates the number of times the body of the
3097 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3098 that by the expression INNER_SIZE. The BLOCK argument specifies the
3099 block in which to calculate the result, and the optional INNER_SIZE_BODY
3100 argument contains any statements that need to executed (inside the loop)
3101 to initialize or calculate INNER_SIZE. */
3104 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
3105 stmtblock_t *inner_size_body, stmtblock_t *block)
3107 forall_info *forall_tmp = nested_forall_info;
3111 /* We can eliminate the innermost unconditional loops with constant
3113 if (INTEGER_CST_P (inner_size))
3116 && !forall_tmp->mask
3117 && INTEGER_CST_P (forall_tmp->size))
3119 inner_size = fold_build2_loc (input_location, MULT_EXPR,
3120 gfc_array_index_type,
3121 inner_size, forall_tmp->size);
3122 forall_tmp = forall_tmp->prev_nest;
3125 /* If there are no loops left, we have our constant result. */
3130 /* Otherwise, create a temporary variable to compute the result. */
3131 number = gfc_create_var (gfc_array_index_type, "num");
3132 gfc_add_modify (block, number, gfc_index_zero_node);
3134 gfc_start_block (&body);
3135 if (inner_size_body)
3136 gfc_add_block_to_block (&body, inner_size_body);
3138 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3139 gfc_array_index_type, number, inner_size);
3142 gfc_add_modify (&body, number, tmp);
3143 tmp = gfc_finish_block (&body);
3145 /* Generate loops. */
3146 if (forall_tmp != NULL)
3147 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
3149 gfc_add_expr_to_block (block, tmp);
3155 /* Allocate temporary for forall construct. SIZE is the size of temporary
3156 needed. PTEMP1 is returned for space free. */
3159 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
3166 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
3167 if (!integer_onep (unit))
3168 bytesize = fold_build2_loc (input_location, MULT_EXPR,
3169 gfc_array_index_type, size, unit);
3174 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
3177 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3182 /* Allocate temporary for forall construct according to the information in
3183 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3184 assignment inside forall. PTEMP1 is returned for space free. */
3187 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
3188 tree inner_size, stmtblock_t * inner_size_body,
3189 stmtblock_t * block, tree * ptemp1)
3193 /* Calculate the total size of temporary needed in forall construct. */
3194 size = compute_overall_iter_number (nested_forall_info, inner_size,
3195 inner_size_body, block);
3197 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
3201 /* Handle assignments inside forall which need temporary.
3203 forall (i=start:end:stride; maskexpr)
3206 (where e,f<i> are arbitrary expressions possibly involving i
3207 and there is a dependency between e<i> and f<i>)
3209 masktmp(:) = maskexpr(:)
3214 for (i = start; i <= end; i += stride)
3218 for (i = start; i <= end; i += stride)
3220 if (masktmp[maskindex++])
3221 tmp[count1++] = f<i>
3225 for (i = start; i <= end; i += stride)
3227 if (masktmp[maskindex++])
3228 e<i> = tmp[count1++]
3233 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3234 tree wheremask, bool invert,
3235 forall_info * nested_forall_info,
3236 stmtblock_t * block)
3244 stmtblock_t inner_size_body;
3246 /* Create vars. count1 is the current iterator number of the nested
3248 count1 = gfc_create_var (gfc_array_index_type, "count1");
3250 /* Count is the wheremask index. */
3253 count = gfc_create_var (gfc_array_index_type, "count");
3254 gfc_add_modify (block, count, gfc_index_zero_node);
3259 /* Initialize count1. */
3260 gfc_add_modify (block, count1, gfc_index_zero_node);
3262 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3263 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3264 gfc_init_block (&inner_size_body);
3265 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
3268 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3269 if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
3271 if (!expr1->ts.u.cl->backend_decl)
3274 gfc_init_se (&tse, NULL);
3275 gfc_conv_expr (&tse, expr1->ts.u.cl->length);
3276 expr1->ts.u.cl->backend_decl = tse.expr;
3278 type = gfc_get_character_type_len (gfc_default_character_kind,
3279 expr1->ts.u.cl->backend_decl);
3282 type = gfc_typenode_for_spec (&expr1->ts);
3284 /* Allocate temporary for nested forall construct according to the
3285 information in nested_forall_info and inner_size. */
3286 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
3287 &inner_size_body, block, &ptemp1);
3289 /* Generate codes to copy rhs to the temporary . */
3290 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
3293 /* Generate body and loops according to the information in
3294 nested_forall_info. */
3295 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3296 gfc_add_expr_to_block (block, tmp);
3299 gfc_add_modify (block, count1, gfc_index_zero_node);
3303 gfc_add_modify (block, count, gfc_index_zero_node);
3305 /* Generate codes to copy the temporary to lhs. */
3306 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
3309 /* Generate body and loops according to the information in
3310 nested_forall_info. */
3311 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3312 gfc_add_expr_to_block (block, tmp);
3316 /* Free the temporary. */
3317 tmp = gfc_call_free (ptemp1);
3318 gfc_add_expr_to_block (block, tmp);
3323 /* Translate pointer assignment inside FORALL which need temporary. */
3326 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3327 forall_info * nested_forall_info,
3328 stmtblock_t * block)
3335 gfc_array_info *info;
3342 tree tmp, tmp1, ptemp1;
3344 count = gfc_create_var (gfc_array_index_type, "count");
3345 gfc_add_modify (block, count, gfc_index_zero_node);
3347 inner_size = gfc_index_one_node;
3348 lss = gfc_walk_expr (expr1);
3349 rss = gfc_walk_expr (expr2);
3350 if (lss == gfc_ss_terminator)
3352 type = gfc_typenode_for_spec (&expr1->ts);
3353 type = build_pointer_type (type);
3355 /* Allocate temporary for nested forall construct according to the
3356 information in nested_forall_info and inner_size. */
3357 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
3358 inner_size, NULL, block, &ptemp1);
3359 gfc_start_block (&body);
3360 gfc_init_se (&lse, NULL);
3361 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3362 gfc_init_se (&rse, NULL);
3363 rse.want_pointer = 1;
3364 gfc_conv_expr (&rse, expr2);
3365 gfc_add_block_to_block (&body, &rse.pre);
3366 gfc_add_modify (&body, lse.expr,
3367 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3368 gfc_add_block_to_block (&body, &rse.post);
3370 /* Increment count. */
3371 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3372 count, gfc_index_one_node);
3373 gfc_add_modify (&body, count, tmp);
3375 tmp = gfc_finish_block (&body);
3377 /* Generate body and loops according to the information in
3378 nested_forall_info. */
3379 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3380 gfc_add_expr_to_block (block, tmp);
3383 gfc_add_modify (block, count, gfc_index_zero_node);
3385 gfc_start_block (&body);
3386 gfc_init_se (&lse, NULL);
3387 gfc_init_se (&rse, NULL);
3388 rse.expr = gfc_build_array_ref (tmp1, count, NULL);
3389 lse.want_pointer = 1;
3390 gfc_conv_expr (&lse, expr1);
3391 gfc_add_block_to_block (&body, &lse.pre);
3392 gfc_add_modify (&body, lse.expr, rse.expr);
3393 gfc_add_block_to_block (&body, &lse.post);
3394 /* Increment count. */
3395 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3396 count, gfc_index_one_node);
3397 gfc_add_modify (&body, count, tmp);
3398 tmp = gfc_finish_block (&body);
3400 /* Generate body and loops according to the information in
3401 nested_forall_info. */
3402 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3403 gfc_add_expr_to_block (block, tmp);
3407 gfc_init_loopinfo (&loop);
3409 /* Associate the SS with the loop. */
3410 gfc_add_ss_to_loop (&loop, rss);
3412 /* Setup the scalarizing loops and bounds. */
3413 gfc_conv_ss_startstride (&loop);
3415 gfc_conv_loop_setup (&loop, &expr2->where);
3417 info = &rss->info->data.array;
3418 desc = info->descriptor;
3420 /* Make a new descriptor. */
3421 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3422 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
3423 loop.from, loop.to, 1,
3424 GFC_ARRAY_UNKNOWN, true);
3426 /* Allocate temporary for nested forall construct. */
3427 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
3428 inner_size, NULL, block, &ptemp1);
3429 gfc_start_block (&body);
3430 gfc_init_se (&lse, NULL);
3431 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3432 lse.direct_byref = 1;
3433 rss = gfc_walk_expr (expr2);
3434 gfc_conv_expr_descriptor (&lse, expr2, rss);
3436 gfc_add_block_to_block (&body, &lse.pre);
3437 gfc_add_block_to_block (&body, &lse.post);
3439 /* Increment count. */
3440 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3441 count, gfc_index_one_node);
3442 gfc_add_modify (&body, count, tmp);
3444 tmp = gfc_finish_block (&body);
3446 /* Generate body and loops according to the information in
3447 nested_forall_info. */
3448 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3449 gfc_add_expr_to_block (block, tmp);
3452 gfc_add_modify (block, count, gfc_index_zero_node);
3454 parm = gfc_build_array_ref (tmp1, count, NULL);
3455 lss = gfc_walk_expr (expr1);
3456 gfc_init_se (&lse, NULL);
3457 gfc_conv_expr_descriptor (&lse, expr1, lss);
3458 gfc_add_modify (&lse.pre, lse.expr, parm);
3459 gfc_start_block (&body);
3460 gfc_add_block_to_block (&body, &lse.pre);
3461 gfc_add_block_to_block (&body, &lse.post);
3463 /* Increment count. */
3464 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3465 count, gfc_index_one_node);
3466 gfc_add_modify (&body, count, tmp);
3468 tmp = gfc_finish_block (&body);
3470 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3471 gfc_add_expr_to_block (block, tmp);
3473 /* Free the temporary. */
3476 tmp = gfc_call_free (ptemp1);
3477 gfc_add_expr_to_block (block, tmp);
3482 /* FORALL and WHERE statements are really nasty, especially when you nest
3483 them. All the rhs of a forall assignment must be evaluated before the
3484 actual assignments are performed. Presumably this also applies to all the
3485 assignments in an inner where statement. */
3487 /* Generate code for a FORALL statement. Any temporaries are allocated as a
3488 linear array, relying on the fact that we process in the same order in all
3491 forall (i=start:end:stride; maskexpr)
3495 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
3497 count = ((end + 1 - start) / stride)
3498 masktmp(:) = maskexpr(:)
3501 for (i = start; i <= end; i += stride)
3503 if (masktmp[maskindex++])
3507 for (i = start; i <= end; i += stride)
3509 if (masktmp[maskindex++])
3513 Note that this code only works when there are no dependencies.
3514 Forall loop with array assignments and data dependencies are a real pain,
3515 because the size of the temporary cannot always be determined before the
3516 loop is executed. This problem is compounded by the presence of nested
3521 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
3538 tree cycle_label = NULL_TREE;
3542 gfc_forall_iterator *fa;
3545 gfc_saved_var *saved_vars;
3546 iter_info *this_forall;
3550 /* Do nothing if the mask is false. */
3552 && code->expr1->expr_type == EXPR_CONSTANT
3553 && !code->expr1->value.logical)
3554 return build_empty_stmt (input_location);
3557 /* Count the FORALL index number. */
3558 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3562 /* Allocate the space for var, start, end, step, varexpr. */
3563 var = XCNEWVEC (tree, nvar);
3564 start = XCNEWVEC (tree, nvar);
3565 end = XCNEWVEC (tree, nvar);
3566 step = XCNEWVEC (tree, nvar);
3567 varexpr = XCNEWVEC (gfc_expr *, nvar);
3568 saved_vars = XCNEWVEC (gfc_saved_var, nvar);
3570 /* Allocate the space for info. */
3571 info = XCNEW (forall_info);
3573 gfc_start_block (&pre);
3574 gfc_init_block (&post);
3575 gfc_init_block (&block);
3578 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3580 gfc_symbol *sym = fa->var->symtree->n.sym;
3582 /* Allocate space for this_forall. */
3583 this_forall = XCNEW (iter_info);
3585 /* Create a temporary variable for the FORALL index. */
3586 tmp = gfc_typenode_for_spec (&sym->ts);
3587 var[n] = gfc_create_var (tmp, sym->name);
3588 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
3590 /* Record it in this_forall. */
3591 this_forall->var = var[n];
3593 /* Replace the index symbol's backend_decl with the temporary decl. */
3594 sym->backend_decl = var[n];
3596 /* Work out the start, end and stride for the loop. */
3597 gfc_init_se (&se, NULL);
3598 gfc_conv_expr_val (&se, fa->start);
3599 /* Record it in this_forall. */
3600 this_forall->start = se.expr;
3601 gfc_add_block_to_block (&block, &se.pre);
3604 gfc_init_se (&se, NULL);
3605 gfc_conv_expr_val (&se, fa->end);
3606 /* Record it in this_forall. */
3607 this_forall->end = se.expr;
3608 gfc_make_safe_expr (&se);
3609 gfc_add_block_to_block (&block, &se.pre);
3612 gfc_init_se (&se, NULL);
3613 gfc_conv_expr_val (&se, fa->stride);
3614 /* Record it in this_forall. */
3615 this_forall->step = se.expr;
3616 gfc_make_safe_expr (&se);
3617 gfc_add_block_to_block (&block, &se.pre);
3620 /* Set the NEXT field of this_forall to NULL. */
3621 this_forall->next = NULL;
3622 /* Link this_forall to the info construct. */
3623 if (info->this_loop)
3625 iter_info *iter_tmp = info->this_loop;
3626 while (iter_tmp->next != NULL)
3627 iter_tmp = iter_tmp->next;
3628 iter_tmp->next = this_forall;
3631 info->this_loop = this_forall;
3637 /* Calculate the size needed for the current forall level. */
3638 size = gfc_index_one_node;
3639 for (n = 0; n < nvar; n++)
3641 /* size = (end + step - start) / step. */
3642 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
3644 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
3646 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
3648 tmp = convert (gfc_array_index_type, tmp);
3650 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3654 /* Record the nvar and size of current forall level. */
3660 /* If the mask is .true., consider the FORALL unconditional. */
3661 if (code->expr1->expr_type == EXPR_CONSTANT
3662 && code->expr1->value.logical)
3670 /* First we need to allocate the mask. */
3673 /* As the mask array can be very big, prefer compact boolean types. */
3674 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3675 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
3676 size, NULL, &block, &pmask);
3677 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
3679 /* Record them in the info structure. */
3680 info->maskindex = maskindex;
3685 /* No mask was specified. */
3686 maskindex = NULL_TREE;
3687 mask = pmask = NULL_TREE;
3690 /* Link the current forall level to nested_forall_info. */
3691 info->prev_nest = nested_forall_info;
3692 nested_forall_info = info;
3694 /* Copy the mask into a temporary variable if required.
3695 For now we assume a mask temporary is needed. */
3698 /* As the mask array can be very big, prefer compact boolean types. */
3699 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3701 gfc_add_modify (&block, maskindex, gfc_index_zero_node);
3703 /* Start of mask assignment loop body. */
3704 gfc_start_block (&body);
3706 /* Evaluate the mask expression. */
3707 gfc_init_se (&se, NULL);
3708 gfc_conv_expr_val (&se, code->expr1);
3709 gfc_add_block_to_block (&body, &se.pre);
3711 /* Store the mask. */
3712 se.expr = convert (mask_type, se.expr);
3714 tmp = gfc_build_array_ref (mask, maskindex, NULL);
3715 gfc_add_modify (&body, tmp, se.expr);
3717 /* Advance to the next mask element. */
3718 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3719 maskindex, gfc_index_one_node);
3720 gfc_add_modify (&body, maskindex, tmp);
3722 /* Generate the loops. */
3723 tmp = gfc_finish_block (&body);
3724 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
3725 gfc_add_expr_to_block (&block, tmp);
3728 if (code->op == EXEC_DO_CONCURRENT)
3730 gfc_init_block (&body);
3731 cycle_label = gfc_build_label_decl (NULL_TREE);
3732 code->cycle_label = cycle_label;
3733 tmp = gfc_trans_code (code->block->next);
3734 gfc_add_expr_to_block (&body, tmp);
3736 if (TREE_USED (cycle_label))
3738 tmp = build1_v (LABEL_EXPR, cycle_label);
3739 gfc_add_expr_to_block (&body, tmp);
3742 tmp = gfc_finish_block (&body);
3743 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3744 gfc_add_expr_to_block (&block, tmp);
3748 c = code->block->next;
3750 /* TODO: loop merging in FORALL statements. */
3751 /* Now that we've got a copy of the mask, generate the assignment loops. */
3757 /* A scalar or array assignment. DO the simple check for
3758 lhs to rhs dependencies. These make a temporary for the
3759 rhs and form a second forall block to copy to variable. */
3760 need_temp = check_forall_dependencies(c, &pre, &post);
3762 /* Temporaries due to array assignment data dependencies introduce
3763 no end of problems. */
3765 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
3766 nested_forall_info, &block);
3769 /* Use the normal assignment copying routines. */
3770 assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
3772 /* Generate body and loops. */
3773 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3775 gfc_add_expr_to_block (&block, tmp);
3778 /* Cleanup any temporary symtrees that have been made to deal
3779 with dependencies. */
3781 cleanup_forall_symtrees (c);
3786 /* Translate WHERE or WHERE construct nested in FORALL. */
3787 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
3790 /* Pointer assignment inside FORALL. */
3791 case EXEC_POINTER_ASSIGN:
3792 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
3794 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
3795 nested_forall_info, &block);
3798 /* Use the normal assignment copying routines. */
3799 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
3801 /* Generate body and loops. */
3802 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3804 gfc_add_expr_to_block (&block, tmp);
3809 tmp = gfc_trans_forall_1 (c, nested_forall_info);
3810 gfc_add_expr_to_block (&block, tmp);
3813 /* Explicit subroutine calls are prevented by the frontend but interface
3814 assignments can legitimately produce them. */
3815 case EXEC_ASSIGN_CALL:
3816 assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
3817 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
3818 gfc_add_expr_to_block (&block, tmp);
3829 /* Restore the original index variables. */
3830 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
3831 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
3833 /* Free the space for var, start, end, step, varexpr. */
3841 for (this_forall = info->this_loop; this_forall;)
3843 iter_info *next = this_forall->next;
3848 /* Free the space for this forall_info. */
3853 /* Free the temporary for the mask. */
3854 tmp = gfc_call_free (pmask);
3855 gfc_add_expr_to_block (&block, tmp);
3858 pushdecl (maskindex);
3860 gfc_add_block_to_block (&pre, &block);
3861 gfc_add_block_to_block (&pre, &post);
3863 return gfc_finish_block (&pre);
3867 /* Translate the FORALL statement or construct. */
3869 tree gfc_trans_forall (gfc_code * code)
3871 return gfc_trans_forall_1 (code, NULL);
3875 /* Translate the DO CONCURRENT construct. */
3877 tree gfc_trans_do_concurrent (gfc_code * code)
3879 return gfc_trans_forall_1 (code, NULL);
3883 /* Evaluate the WHERE mask expression, copy its value to a temporary.
3884 If the WHERE construct is nested in FORALL, compute the overall temporary
3885 needed by the WHERE mask expression multiplied by the iterator number of
3887 ME is the WHERE mask expression.
3888 MASK is the current execution mask upon input, whose sense may or may
3889 not be inverted as specified by the INVERT argument.
3890 CMASK is the updated execution mask on output, or NULL if not required.
3891 PMASK is the pending execution mask on output, or NULL if not required.
3892 BLOCK is the block in which to place the condition evaluation loops. */
3895 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
3896 tree mask, bool invert, tree cmask, tree pmask,
3897 tree mask_type, stmtblock_t * block)
3902 stmtblock_t body, body1;
3903 tree count, cond, mtmp;
3906 gfc_init_loopinfo (&loop);
3908 lss = gfc_walk_expr (me);
3909 rss = gfc_walk_expr (me);
3911 /* Variable to index the temporary. */
3912 count = gfc_create_var (gfc_array_index_type, "count");
3913 /* Initialize count. */
3914 gfc_add_modify (block, count, gfc_index_zero_node);
3916 gfc_start_block (&body);
3918 gfc_init_se (&rse, NULL);
3919 gfc_init_se (&lse, NULL);
3921 if (lss == gfc_ss_terminator)
3923 gfc_init_block (&body1);
3927 /* Initialize the loop. */
3928 gfc_init_loopinfo (&loop);
3930 /* We may need LSS to determine the shape of the expression. */
3931 gfc_add_ss_to_loop (&loop, lss);
3932 gfc_add_ss_to_loop (&loop, rss);
3934 gfc_conv_ss_startstride (&loop);
3935 gfc_conv_loop_setup (&loop, &me->where);
3937 gfc_mark_ss_chain_used (rss, 1);
3938 /* Start the loop body. */
3939 gfc_start_scalarized_body (&loop, &body1);
3941 /* Translate the expression. */
3942 gfc_copy_loopinfo_to_se (&rse, &loop);
3944 gfc_conv_expr (&rse, me);
3947 /* Variable to evaluate mask condition. */
3948 cond = gfc_create_var (mask_type, "cond");
3949 if (mask && (cmask || pmask))
3950 mtmp = gfc_create_var (mask_type, "mask");
3951 else mtmp = NULL_TREE;
3953 gfc_add_block_to_block (&body1, &lse.pre);
3954 gfc_add_block_to_block (&body1, &rse.pre);
3956 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
3958 if (mask && (cmask || pmask))
3960 tmp = gfc_build_array_ref (mask, count, NULL);
3962 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
3963 gfc_add_modify (&body1, mtmp, tmp);
3968 tmp1 = gfc_build_array_ref (cmask, count, NULL);
3971 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
3973 gfc_add_modify (&body1, tmp1, tmp);
3978 tmp1 = gfc_build_array_ref (pmask, count, NULL);
3979 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
3981 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
3983 gfc_add_modify (&body1, tmp1, tmp);
3986 gfc_add_block_to_block (&body1, &lse.post);
3987 gfc_add_block_to_block (&body1, &rse.post);
3989 if (lss == gfc_ss_terminator)
3991 gfc_add_block_to_block (&body, &body1);
3995 /* Increment count. */
3996 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3997 count, gfc_index_one_node);
3998 gfc_add_modify (&body1, count, tmp1);
4000 /* Generate the copying loops. */
4001 gfc_trans_scalarizing_loops (&loop, &body1);
4003 gfc_add_block_to_block (&body, &loop.pre);
4004 gfc_add_block_to_block (&body, &loop.post);
4006 gfc_cleanup_loop (&loop);
4007 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4008 as tree nodes in SS may not be valid in different scope. */
4011 tmp1 = gfc_finish_block (&body);
4012 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4013 if (nested_forall_info != NULL)
4014 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
4016 gfc_add_expr_to_block (block, tmp1);
4020 /* Translate an assignment statement in a WHERE statement or construct
4021 statement. The MASK expression is used to control which elements
4022 of EXPR1 shall be assigned. The sense of MASK is specified by
4026 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
4027 tree mask, bool invert,
4028 tree count1, tree count2,
4034 gfc_ss *lss_section;
4041 tree index, maskexpr;
4043 /* A defined assignment. */
4044 if (cnext && cnext->resolved_sym)
4045 return gfc_trans_call (cnext, true, mask, count1, invert);
4048 /* TODO: handle this special case.
4049 Special case a single function returning an array. */
4050 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4052 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4058 /* Assignment of the form lhs = rhs. */
4059 gfc_start_block (&block);
4061 gfc_init_se (&lse, NULL);
4062 gfc_init_se (&rse, NULL);
4065 lss = gfc_walk_expr (expr1);
4068 /* In each where-assign-stmt, the mask-expr and the variable being
4069 defined shall be arrays of the same shape. */
4070 gcc_assert (lss != gfc_ss_terminator);
4072 /* The assignment needs scalarization. */
4075 /* Find a non-scalar SS from the lhs. */
4076 while (lss_section != gfc_ss_terminator
4077 && lss_section->info->type != GFC_SS_SECTION)
4078 lss_section = lss_section->next;
4080 gcc_assert (lss_section != gfc_ss_terminator);
4082 /* Initialize the scalarizer. */
4083 gfc_init_loopinfo (&loop);
4086 rss = gfc_walk_expr (expr2);
4087 if (rss == gfc_ss_terminator)
4089 /* The rhs is scalar. Add a ss for the expression. */
4090 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4091 rss->info->where = 1;
4094 /* Associate the SS with the loop. */
4095 gfc_add_ss_to_loop (&loop, lss);
4096 gfc_add_ss_to_loop (&loop, rss);
4098 /* Calculate the bounds of the scalarization. */
4099 gfc_conv_ss_startstride (&loop);
4101 /* Resolve any data dependencies in the statement. */
4102 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
4104 /* Setup the scalarizing loops. */
4105 gfc_conv_loop_setup (&loop, &expr2->where);
4107 /* Setup the gfc_se structures. */
4108 gfc_copy_loopinfo_to_se (&lse, &loop);
4109 gfc_copy_loopinfo_to_se (&rse, &loop);
4112 gfc_mark_ss_chain_used (rss, 1);
4113 if (loop.temp_ss == NULL)
4116 gfc_mark_ss_chain_used (lss, 1);
4120 lse.ss = loop.temp_ss;
4121 gfc_mark_ss_chain_used (lss, 3);
4122 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4125 /* Start the scalarized loop body. */
4126 gfc_start_scalarized_body (&loop, &body);
4128 /* Translate the expression. */
4129 gfc_conv_expr (&rse, expr2);
4130 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
4131 gfc_conv_tmp_array_ref (&lse);
4133 gfc_conv_expr (&lse, expr1);
4135 /* Form the mask expression according to the mask. */
4137 maskexpr = gfc_build_array_ref (mask, index, NULL);
4139 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4140 TREE_TYPE (maskexpr), maskexpr);
4142 /* Use the scalar assignment as is. */
4143 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4144 loop.temp_ss != NULL, false, true);
4146 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
4148 gfc_add_expr_to_block (&body, tmp);
4150 if (lss == gfc_ss_terminator)
4152 /* Increment count1. */
4153 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4154 count1, gfc_index_one_node);
4155 gfc_add_modify (&body, count1, tmp);
4157 /* Use the scalar assignment as is. */
4158 gfc_add_block_to_block (&block, &body);
4162 gcc_assert (lse.ss == gfc_ss_terminator
4163 && rse.ss == gfc_ss_terminator);
4165 if (loop.temp_ss != NULL)
4167 /* Increment count1 before finish the main body of a scalarized
4169 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4170 gfc_array_index_type, count1, gfc_index_one_node);
4171 gfc_add_modify (&body, count1, tmp);
4172 gfc_trans_scalarized_loop_boundary (&loop, &body);
4174 /* We need to copy the temporary to the actual lhs. */
4175 gfc_init_se (&lse, NULL);
4176 gfc_init_se (&rse, NULL);
4177 gfc_copy_loopinfo_to_se (&lse, &loop);
4178 gfc_copy_loopinfo_to_se (&rse, &loop);
4180 rse.ss = loop.temp_ss;
4183 gfc_conv_tmp_array_ref (&rse);
4184 gfc_conv_expr (&lse, expr1);
4186 gcc_assert (lse.ss == gfc_ss_terminator
4187 && rse.ss == gfc_ss_terminator);
4189 /* Form the mask expression according to the mask tree list. */
4191 maskexpr = gfc_build_array_ref (mask, index, NULL);
4193 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4194 TREE_TYPE (maskexpr), maskexpr);
4196 /* Use the scalar assignment as is. */
4197 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
4199 tmp = build3_v (COND_EXPR, maskexpr, tmp,
4200 build_empty_stmt (input_location));
4201 gfc_add_expr_to_block (&body, tmp);
4203 /* Increment count2. */
4204 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4205 gfc_array_index_type, count2,
4206 gfc_index_one_node);
4207 gfc_add_modify (&body, count2, tmp);
4211 /* Increment count1. */
4212 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4213 gfc_array_index_type, count1,
4214 gfc_index_one_node);
4215 gfc_add_modify (&body, count1, tmp);
4218 /* Generate the copying loops. */
4219 gfc_trans_scalarizing_loops (&loop, &body);
4221 /* Wrap the whole thing up. */
4222 gfc_add_block_to_block (&block, &loop.pre);
4223 gfc_add_block_to_block (&block, &loop.post);
4224 gfc_cleanup_loop (&loop);
4227 return gfc_finish_block (&block);
4231 /* Translate the WHERE construct or statement.
4232 This function can be called iteratively to translate the nested WHERE
4233 construct or statement.
4234 MASK is the control mask. */
4237 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
4238 forall_info * nested_forall_info, stmtblock_t * block)
4240 stmtblock_t inner_size_body;
4241 tree inner_size, size;
4250 tree count1, count2;
4254 tree pcmask = NULL_TREE;
4255 tree ppmask = NULL_TREE;
4256 tree cmask = NULL_TREE;
4257 tree pmask = NULL_TREE;
4258 gfc_actual_arglist *arg;
4260 /* the WHERE statement or the WHERE construct statement. */
4261 cblock = code->block;
4263 /* As the mask array can be very big, prefer compact boolean types. */
4264 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
4266 /* Determine which temporary masks are needed. */
4269 /* One clause: No ELSEWHEREs. */
4270 need_cmask = (cblock->next != 0);
4273 else if (cblock->block->block)
4275 /* Three or more clauses: Conditional ELSEWHEREs. */
4279 else if (cblock->next)
4281 /* Two clauses, the first non-empty. */
4283 need_pmask = (mask != NULL_TREE
4284 && cblock->block->next != 0);
4286 else if (!cblock->block->next)
4288 /* Two clauses, both empty. */
4292 /* Two clauses, the first empty, the second non-empty. */
4295 need_cmask = (cblock->block->expr1 != 0);
4304 if (need_cmask || need_pmask)
4306 /* Calculate the size of temporary needed by the mask-expr. */
4307 gfc_init_block (&inner_size_body);
4308 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
4309 &inner_size_body, &lss, &rss);
4311 gfc_free_ss_chain (lss);
4312 gfc_free_ss_chain (rss);
4314 /* Calculate the total size of temporary needed. */
4315 size = compute_overall_iter_number (nested_forall_info, inner_size,
4316 &inner_size_body, block);
4318 /* Check whether the size is negative. */
4319 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
4320 gfc_index_zero_node);
4321 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4322 cond, gfc_index_zero_node, size);
4323 size = gfc_evaluate_now (size, block);
4325 /* Allocate temporary for WHERE mask if needed. */
4327 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4330 /* Allocate temporary for !mask if needed. */
4332 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4338 /* Each time around this loop, the where clause is conditional
4339 on the value of mask and invert, which are updated at the
4340 bottom of the loop. */
4342 /* Has mask-expr. */
4345 /* Ensure that the WHERE mask will be evaluated exactly once.
4346 If there are no statements in this WHERE/ELSEWHERE clause,
4347 then we don't need to update the control mask (cmask).
4348 If this is the last clause of the WHERE construct, then
4349 we don't need to update the pending control mask (pmask). */
4351 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4353 cblock->next ? cmask : NULL_TREE,
4354 cblock->block ? pmask : NULL_TREE,
4357 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4359 (cblock->next || cblock->block)
4360 ? cmask : NULL_TREE,
4361 NULL_TREE, mask_type, block);
4365 /* It's a final elsewhere-stmt. No mask-expr is present. */
4369 /* The body of this where clause are controlled by cmask with
4370 sense specified by invert. */
4372 /* Get the assignment statement of a WHERE statement, or the first
4373 statement in where-body-construct of a WHERE construct. */
4374 cnext = cblock->next;
4379 /* WHERE assignment statement. */
4380 case EXEC_ASSIGN_CALL:
4382 arg = cnext->ext.actual;
4383 expr1 = expr2 = NULL;
4384 for (; arg; arg = arg->next)
4396 expr1 = cnext->expr1;
4397 expr2 = cnext->expr2;
4399 if (nested_forall_info != NULL)
4401 need_temp = gfc_check_dependency (expr1, expr2, 0);
4402 if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
4403 gfc_trans_assign_need_temp (expr1, expr2,
4405 nested_forall_info, block);
4408 /* Variables to control maskexpr. */
4409 count1 = gfc_create_var (gfc_array_index_type, "count1");
4410 count2 = gfc_create_var (gfc_array_index_type, "count2");
4411 gfc_add_modify (block, count1, gfc_index_zero_node);
4412 gfc_add_modify (block, count2, gfc_index_zero_node);
4414 tmp = gfc_trans_where_assign (expr1, expr2,
4419 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
4421 gfc_add_expr_to_block (block, tmp);
4426 /* Variables to control maskexpr. */
4427 count1 = gfc_create_var (gfc_array_index_type, "count1");
4428 count2 = gfc_create_var (gfc_array_index_type, "count2");
4429 gfc_add_modify (block, count1, gfc_index_zero_node);
4430 gfc_add_modify (block, count2, gfc_index_zero_node);
4432 tmp = gfc_trans_where_assign (expr1, expr2,
4436 gfc_add_expr_to_block (block, tmp);
4441 /* WHERE or WHERE construct is part of a where-body-construct. */
4443 gfc_trans_where_2 (cnext, cmask, invert,
4444 nested_forall_info, block);
4451 /* The next statement within the same where-body-construct. */
4452 cnext = cnext->next;
4454 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
4455 cblock = cblock->block;
4456 if (mask == NULL_TREE)
4458 /* If we're the initial WHERE, we can simply invert the sense
4459 of the current mask to obtain the "mask" for the remaining
4466 /* Otherwise, for nested WHERE's we need to use the pending mask. */
4472 /* If we allocated a pending mask array, deallocate it now. */
4475 tmp = gfc_call_free (ppmask);
4476 gfc_add_expr_to_block (block, tmp);
4479 /* If we allocated a current mask array, deallocate it now. */
4482 tmp = gfc_call_free (pcmask);
4483 gfc_add_expr_to_block (block, tmp);
4487 /* Translate a simple WHERE construct or statement without dependencies.
4488 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
4489 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
4490 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
4493 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
4495 stmtblock_t block, body;
4496 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
4497 tree tmp, cexpr, tstmt, estmt;
4498 gfc_ss *css, *tdss, *tsss;
4499 gfc_se cse, tdse, tsse, edse, esse;
4504 /* Allow the scalarizer to workshare simple where loops. */
4505 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4506 ompws_flags |= OMPWS_SCALARIZER_WS;
4508 cond = cblock->expr1;
4509 tdst = cblock->next->expr1;
4510 tsrc = cblock->next->expr2;
4511 edst = eblock ? eblock->next->expr1 : NULL;
4512 esrc = eblock ? eblock->next->expr2 : NULL;
4514 gfc_start_block (&block);
4515 gfc_init_loopinfo (&loop);
4517 /* Handle the condition. */
4518 gfc_init_se (&cse, NULL);
4519 css = gfc_walk_expr (cond);
4520 gfc_add_ss_to_loop (&loop, css);
4522 /* Handle the then-clause. */
4523 gfc_init_se (&tdse, NULL);
4524 gfc_init_se (&tsse, NULL);
4525 tdss = gfc_walk_expr (tdst);
4526 tsss = gfc_walk_expr (tsrc);
4527 if (tsss == gfc_ss_terminator)
4529 tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
4530 tsss->info->where = 1;
4532 gfc_add_ss_to_loop (&loop, tdss);
4533 gfc_add_ss_to_loop (&loop, tsss);
4537 /* Handle the else clause. */
4538 gfc_init_se (&edse, NULL);
4539 gfc_init_se (&esse, NULL);
4540 edss = gfc_walk_expr (edst);
4541 esss = gfc_walk_expr (esrc);
4542 if (esss == gfc_ss_terminator)
4544 esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
4545 esss->info->where = 1;
4547 gfc_add_ss_to_loop (&loop, edss);
4548 gfc_add_ss_to_loop (&loop, esss);
4551 gfc_conv_ss_startstride (&loop);
4552 gfc_conv_loop_setup (&loop, &tdst->where);
4554 gfc_mark_ss_chain_used (css, 1);
4555 gfc_mark_ss_chain_used (tdss, 1);
4556 gfc_mark_ss_chain_used (tsss, 1);
4559 gfc_mark_ss_chain_used (edss, 1);
4560 gfc_mark_ss_chain_used (esss, 1);
4563 gfc_start_scalarized_body (&loop, &body);
4565 gfc_copy_loopinfo_to_se (&cse, &loop);
4566 gfc_copy_loopinfo_to_se (&tdse, &loop);
4567 gfc_copy_loopinfo_to_se (&tsse, &loop);
4573 gfc_copy_loopinfo_to_se (&edse, &loop);
4574 gfc_copy_loopinfo_to_se (&esse, &loop);
4579 gfc_conv_expr (&cse, cond);
4580 gfc_add_block_to_block (&body, &cse.pre);
4583 gfc_conv_expr (&tsse, tsrc);
4584 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
4585 gfc_conv_tmp_array_ref (&tdse);
4587 gfc_conv_expr (&tdse, tdst);
4591 gfc_conv_expr (&esse, esrc);
4592 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
4593 gfc_conv_tmp_array_ref (&edse);
4595 gfc_conv_expr (&edse, edst);
4598 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
4599 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
4601 : build_empty_stmt (input_location);
4602 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
4603 gfc_add_expr_to_block (&body, tmp);
4604 gfc_add_block_to_block (&body, &cse.post);
4606 gfc_trans_scalarizing_loops (&loop, &body);
4607 gfc_add_block_to_block (&block, &loop.pre);
4608 gfc_add_block_to_block (&block, &loop.post);
4609 gfc_cleanup_loop (&loop);
4611 return gfc_finish_block (&block);
4614 /* As the WHERE or WHERE construct statement can be nested, we call
4615 gfc_trans_where_2 to do the translation, and pass the initial
4616 NULL values for both the control mask and the pending control mask. */
4619 gfc_trans_where (gfc_code * code)
4625 cblock = code->block;
4627 && cblock->next->op == EXEC_ASSIGN
4628 && !cblock->next->next)
4630 eblock = cblock->block;
4633 /* A simple "WHERE (cond) x = y" statement or block is
4634 dependence free if cond is not dependent upon writing x,
4635 and the source y is unaffected by the destination x. */
4636 if (!gfc_check_dependency (cblock->next->expr1,
4638 && !gfc_check_dependency (cblock->next->expr1,
4639 cblock->next->expr2, 0))
4640 return gfc_trans_where_3 (cblock, NULL);
4642 else if (!eblock->expr1
4645 && eblock->next->op == EXEC_ASSIGN
4646 && !eblock->next->next)
4648 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
4649 block is dependence free if cond is not dependent on writes
4650 to x1 and x2, y1 is not dependent on writes to x2, and y2
4651 is not dependent on writes to x1, and both y's are not
4652 dependent upon their own x's. In addition to this, the
4653 final two dependency checks below exclude all but the same
4654 array reference if the where and elswhere destinations
4655 are the same. In short, this is VERY conservative and this
4656 is needed because the two loops, required by the standard
4657 are coalesced in gfc_trans_where_3. */
4658 if (!gfc_check_dependency(cblock->next->expr1,
4660 && !gfc_check_dependency(eblock->next->expr1,
4662 && !gfc_check_dependency(cblock->next->expr1,
4663 eblock->next->expr2, 1)
4664 && !gfc_check_dependency(eblock->next->expr1,
4665 cblock->next->expr2, 1)
4666 && !gfc_check_dependency(cblock->next->expr1,
4667 cblock->next->expr2, 1)
4668 && !gfc_check_dependency(eblock->next->expr1,
4669 eblock->next->expr2, 1)
4670 && !gfc_check_dependency(cblock->next->expr1,
4671 eblock->next->expr1, 0)
4672 && !gfc_check_dependency(eblock->next->expr1,
4673 cblock->next->expr1, 0))
4674 return gfc_trans_where_3 (cblock, eblock);
4678 gfc_start_block (&block);
4680 gfc_trans_where_2 (code, NULL, false, NULL, &block);
4682 return gfc_finish_block (&block);
4686 /* CYCLE a DO loop. The label decl has already been created by
4687 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
4688 node at the head of the loop. We must mark the label as used. */
4691 gfc_trans_cycle (gfc_code * code)
4695 cycle_label = code->ext.which_construct->cycle_label;
4696 gcc_assert (cycle_label);
4698 TREE_USED (cycle_label) = 1;
4699 return build1_v (GOTO_EXPR, cycle_label);
4703 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
4704 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
4708 gfc_trans_exit (gfc_code * code)
4712 exit_label = code->ext.which_construct->exit_label;
4713 gcc_assert (exit_label);
4715 TREE_USED (exit_label) = 1;
4716 return build1_v (GOTO_EXPR, exit_label);
4720 /* Translate the ALLOCATE statement. */
4723 gfc_trans_allocate (gfc_code * code)
4745 tree memsize = NULL_TREE;
4746 tree classexpr = NULL_TREE;
4748 if (!code->ext.alloc.list)
4751 stat = tmp = memsz = NULL_TREE;
4752 label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
4754 gfc_init_block (&block);
4755 gfc_init_block (&post);
4757 /* STAT= (and maybe ERRMSG=) is present. */
4761 tree gfc_int4_type_node = gfc_get_int_type (4);
4762 stat = gfc_create_var (gfc_int4_type_node, "stat");
4764 /* ERRMSG= only makes sense with STAT=. */
4767 gfc_init_se (&se, NULL);
4768 se.want_pointer = 1;
4769 gfc_conv_expr_lhs (&se, code->expr2);
4771 errlen = se.string_length;
4775 errmsg = null_pointer_node;
4776 errlen = build_int_cst (gfc_charlen_type_node, 0);
4779 /* GOTO destinations. */
4780 label_errmsg = gfc_build_label_decl (NULL_TREE);
4781 label_finish = gfc_build_label_decl (NULL_TREE);
4782 TREE_USED (label_finish) = 0;
4788 for (al = code->ext.alloc.list; al != NULL; al = al->next)
4790 expr = gfc_copy_expr (al->expr);
4792 if (expr->ts.type == BT_CLASS)
4793 gfc_add_data_component (expr);
4795 gfc_init_se (&se, NULL);
4797 se.want_pointer = 1;
4798 se.descriptor_only = 1;
4799 gfc_conv_expr (&se, expr);
4801 /* Evaluate expr3 just once if not a variable. */
4802 if (al == code->ext.alloc.list
4803 && al->expr->ts.type == BT_CLASS
4805 && code->expr3->ts.type == BT_CLASS
4806 && code->expr3->expr_type != EXPR_VARIABLE)
4808 gfc_init_se (&se_sz, NULL);
4809 gfc_conv_expr_reference (&se_sz, code->expr3);
4810 gfc_conv_class_to_class (&se_sz, code->expr3,
4811 code->expr3->ts, false);
4812 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4813 gfc_add_block_to_block (&se.post, &se_sz.post);
4814 classexpr = build_fold_indirect_ref_loc (input_location,
4816 classexpr = gfc_evaluate_now (classexpr, &se.pre);
4817 memsize = gfc_vtable_size_get (classexpr);
4818 memsize = fold_convert (sizetype, memsize);
4822 class_expr = classexpr;
4825 if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
4826 memsz, &nelems, code->expr3))
4828 /* A scalar or derived type. */
4830 /* Determine allocate size. */
4831 if (al->expr->ts.type == BT_CLASS
4833 && memsz == NULL_TREE)
4835 if (code->expr3->ts.type == BT_CLASS)
4837 sz = gfc_copy_expr (code->expr3);
4838 gfc_add_vptr_component (sz);
4839 gfc_add_size_component (sz);
4840 gfc_init_se (&se_sz, NULL);
4841 gfc_conv_expr (&se_sz, sz);
4846 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
4848 else if (al->expr->ts.type == BT_CHARACTER
4849 && al->expr->ts.deferred && code->expr3)
4851 if (!code->expr3->ts.u.cl->backend_decl)
4853 /* Convert and use the length expression. */
4854 gfc_init_se (&se_sz, NULL);
4855 if (code->expr3->expr_type == EXPR_VARIABLE
4856 || code->expr3->expr_type == EXPR_CONSTANT)
4858 gfc_conv_expr (&se_sz, code->expr3);
4859 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4861 = gfc_evaluate_now (se_sz.string_length, &se.pre);
4862 gfc_add_block_to_block (&se.pre, &se_sz.post);
4863 memsz = se_sz.string_length;
4865 else if (code->expr3->mold
4866 && code->expr3->ts.u.cl
4867 && code->expr3->ts.u.cl->length)
4869 gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
4870 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4871 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
4872 gfc_add_block_to_block (&se.pre, &se_sz.post);
4877 /* This is would be inefficient and possibly could
4878 generate wrong code if the result were not stored
4880 if (slen3 == NULL_TREE)
4882 gfc_conv_expr (&se_sz, code->expr3);
4883 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4884 expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
4885 gfc_add_block_to_block (&post, &se_sz.post);
4886 slen3 = gfc_evaluate_now (se_sz.string_length,
4893 /* Otherwise use the stored string length. */
4894 memsz = code->expr3->ts.u.cl->backend_decl;
4895 tmp = al->expr->ts.u.cl->backend_decl;
4897 /* Store the string length. */
4898 if (tmp && TREE_CODE (tmp) == VAR_DECL)
4899 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
4902 /* Convert to size in bytes, using the character KIND. */
4903 tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
4904 tmp = TYPE_SIZE_UNIT (tmp);
4905 memsz = fold_build2_loc (input_location, MULT_EXPR,
4906 TREE_TYPE (tmp), tmp,
4907 fold_convert (TREE_TYPE (tmp), memsz));
4909 else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
4911 gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
4912 gfc_init_se (&se_sz, NULL);
4913 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
4914 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4915 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
4916 gfc_add_block_to_block (&se.pre, &se_sz.post);
4917 /* Store the string length. */
4918 tmp = al->expr->ts.u.cl->backend_decl;
4919 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
4921 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
4922 tmp = TYPE_SIZE_UNIT (tmp);
4923 memsz = fold_build2_loc (input_location, MULT_EXPR,
4924 TREE_TYPE (tmp), tmp,
4925 fold_convert (TREE_TYPE (se_sz.expr),
4928 else if (code->ext.alloc.ts.type != BT_UNKNOWN)
4929 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
4930 else if (memsz == NULL_TREE)
4931 memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
4933 if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
4935 memsz = se.string_length;
4937 /* Convert to size in bytes, using the character KIND. */
4938 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
4939 tmp = TYPE_SIZE_UNIT (tmp);
4940 memsz = fold_build2_loc (input_location, MULT_EXPR,
4941 TREE_TYPE (tmp), tmp,
4942 fold_convert (TREE_TYPE (tmp), memsz));
4945 /* Allocate - for non-pointers with re-alloc checking. */
4946 if (gfc_expr_attr (expr).allocatable)
4947 gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
4948 stat, errmsg, errlen, label_finish, expr);
4950 gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
4952 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
4954 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
4955 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
4956 gfc_add_expr_to_block (&se.pre, tmp);
4958 else if (al->expr->ts.type == BT_CLASS && code->expr3)
4960 /* With class objects, it is best to play safe and null the
4961 memory because we cannot know if dynamic types have allocatable
4962 components or not. */
4963 tmp = build_call_expr_loc (input_location,
4964 builtin_decl_explicit (BUILT_IN_MEMSET),
4965 3, se.expr, integer_zero_node, memsz);
4966 gfc_add_expr_to_block (&se.pre, tmp);
4970 gfc_add_block_to_block (&block, &se.pre);
4972 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
4975 tmp = build1_v (GOTO_EXPR, label_errmsg);
4976 parm = fold_build2_loc (input_location, NE_EXPR,
4977 boolean_type_node, stat,
4978 build_int_cst (TREE_TYPE (stat), 0));
4979 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4980 gfc_unlikely (parm), tmp,
4981 build_empty_stmt (input_location));
4982 gfc_add_expr_to_block (&block, tmp);
4985 /* We need the vptr of CLASS objects to be initialized. */
4986 e = gfc_copy_expr (al->expr);
4987 if (e->ts.type == BT_CLASS)
4989 gfc_expr *lhs, *rhs;
4992 lhs = gfc_expr_to_initialize (e);
4993 gfc_add_vptr_component (lhs);
4995 if (class_expr != NULL_TREE)
4997 /* Polymorphic SOURCE: VPTR must be determined at run time. */
4998 gfc_init_se (&lse, NULL);
4999 lse.want_pointer = 1;
5000 gfc_conv_expr (&lse, lhs);
5001 tmp = gfc_class_vptr_get (class_expr);
5002 gfc_add_modify (&block, lse.expr,
5003 fold_convert (TREE_TYPE (lse.expr), tmp));
5005 else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
5007 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5008 rhs = gfc_copy_expr (code->expr3);
5009 gfc_add_vptr_component (rhs);
5010 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5011 gfc_add_expr_to_block (&block, tmp);
5012 gfc_free_expr (rhs);
5013 rhs = gfc_expr_to_initialize (e);
5017 /* VPTR is fixed at compile time. */
5021 ts = &code->expr3->ts;
5022 else if (e->ts.type == BT_DERIVED)
5024 else if (code->ext.alloc.ts.type == BT_DERIVED)
5025 ts = &code->ext.alloc.ts;
5026 else if (e->ts.type == BT_CLASS)
5027 ts = &CLASS_DATA (e)->ts;
5031 if (ts->type == BT_DERIVED)
5033 vtab = gfc_find_derived_vtab (ts->u.derived);
5035 gfc_init_se (&lse, NULL);
5036 lse.want_pointer = 1;
5037 gfc_conv_expr (&lse, lhs);
5038 tmp = gfc_build_addr_expr (NULL_TREE,
5039 gfc_get_symbol_decl (vtab));
5040 gfc_add_modify (&block, lse.expr,
5041 fold_convert (TREE_TYPE (lse.expr), tmp));
5044 gfc_free_expr (lhs);
5049 if (code->expr3 && !code->expr3->mold)
5051 /* Initialization via SOURCE block
5052 (or static default initializer). */
5053 gfc_expr *rhs = gfc_copy_expr (code->expr3);
5054 if (class_expr != NULL_TREE)
5057 to = TREE_OPERAND (se.expr, 0);
5059 tmp = gfc_copy_class_to_class (class_expr, to, nelems);
5061 else if (al->expr->ts.type == BT_CLASS)
5063 gfc_actual_arglist *actual;
5068 /* Do a polymorphic deep copy. */
5069 actual = gfc_get_actual_arglist ();
5070 actual->expr = gfc_copy_expr (rhs);
5071 if (rhs->ts.type == BT_CLASS)
5072 gfc_add_data_component (actual->expr);
5073 actual->next = gfc_get_actual_arglist ();
5074 actual->next->expr = gfc_copy_expr (al->expr);
5075 actual->next->expr->ts.type = BT_CLASS;
5076 gfc_add_data_component (actual->next->expr);
5077 dataref = actual->next->expr->ref;
5078 if (dataref->u.c.component->as)
5082 gfc_ref *ref = dataref->next;
5083 ref->u.ar.type = AR_SECTION;
5084 /* We have to set up the array reference to give ranges
5085 in all dimensions and ensure that the end and stride
5086 are set so that the copy can be scalarized. */
5088 for (; dim < dataref->u.c.component->as->rank; dim++)
5090 ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
5091 if (ref->u.ar.end[dim] == NULL)
5093 ref->u.ar.end[dim] = ref->u.ar.start[dim];
5094 temp = gfc_get_int_expr (gfc_default_integer_kind,
5095 &al->expr->where, 1);
5096 ref->u.ar.start[dim] = temp;
5098 temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
5099 gfc_copy_expr (ref->u.ar.start[dim]));
5100 temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
5101 &al->expr->where, 1),
5105 if (rhs->ts.type == BT_CLASS)
5107 ppc = gfc_copy_expr (rhs);
5108 gfc_add_vptr_component (ppc);
5111 ppc = gfc_lval_expr_from_sym
5112 (gfc_find_derived_vtab (rhs->ts.u.derived));
5113 gfc_add_component_ref (ppc, "_copy");
5115 ppc_code = gfc_get_code ();
5116 ppc_code->resolved_sym = ppc->symtree->n.sym;
5117 /* Although '_copy' is set to be elemental in class.c, it is
5118 not staying that way. Find out why, sometime.... */
5119 ppc_code->resolved_sym->attr.elemental = 1;
5120 ppc_code->ext.actual = actual;
5121 ppc_code->expr1 = ppc;
5122 ppc_code->op = EXEC_CALL;
5123 /* Since '_copy' is elemental, the scalarizer will take care
5124 of arrays in gfc_trans_call. */
5125 tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
5126 gfc_free_statements (ppc_code);
5128 else if (expr3 != NULL_TREE)
5130 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
5131 gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
5132 slen3, expr3, code->expr3->ts.kind);
5137 /* Switch off automatic reallocation since we have just done
5139 int realloc_lhs = gfc_option.flag_realloc_lhs;
5140 gfc_option.flag_realloc_lhs = 0;
5141 tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
5143 gfc_option.flag_realloc_lhs = realloc_lhs;
5145 gfc_free_expr (rhs);
5146 gfc_add_expr_to_block (&block, tmp);
5148 else if (code->expr3 && code->expr3->mold
5149 && code->expr3->ts.type == BT_CLASS)
5151 /* Since the _vptr has already been assigned to the allocate
5152 object, we can use gfc_copy_class_to_class in its
5153 initialization mode. */
5154 tmp = TREE_OPERAND (se.expr, 0);
5155 tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
5156 gfc_add_expr_to_block (&block, tmp);
5159 gfc_free_expr (expr);
5165 tmp = build1_v (LABEL_EXPR, label_errmsg);
5166 gfc_add_expr_to_block (&block, tmp);
5169 /* ERRMSG - only useful if STAT is present. */
5170 if (code->expr1 && code->expr2)
5172 const char *msg = "Attempt to allocate an allocated object";
5173 tree slen, dlen, errmsg_str;
5174 stmtblock_t errmsg_block;
5176 gfc_init_block (&errmsg_block);
5178 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
5179 gfc_add_modify (&errmsg_block, errmsg_str,
5180 gfc_build_addr_expr (pchar_type_node,
5181 gfc_build_localized_cstring_const (msg)));
5183 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5184 dlen = gfc_get_expr_charlen (code->expr2);
5185 slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
5188 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
5189 slen, errmsg_str, gfc_default_character_kind);
5190 dlen = gfc_finish_block (&errmsg_block);
5192 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5193 build_int_cst (TREE_TYPE (stat), 0));
5195 tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
5197 gfc_add_expr_to_block (&block, tmp);
5203 if (TREE_USED (label_finish))
5205 tmp = build1_v (LABEL_EXPR, label_finish);
5206 gfc_add_expr_to_block (&block, tmp);
5209 gfc_init_se (&se, NULL);
5210 gfc_conv_expr_lhs (&se, code->expr1);
5211 tmp = convert (TREE_TYPE (se.expr), stat);
5212 gfc_add_modify (&block, se.expr, tmp);
5215 gfc_add_block_to_block (&block, &se.post);
5216 gfc_add_block_to_block (&block, &post);
5218 return gfc_finish_block (&block);
5222 /* Translate a DEALLOCATE statement. */
5225 gfc_trans_deallocate (gfc_code *code)
5229 tree apstat, pstat, stat, errmsg, errlen, tmp;
5230 tree label_finish, label_errmsg;
5233 pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
5234 label_finish = label_errmsg = NULL_TREE;
5236 gfc_start_block (&block);
5238 /* Count the number of failed deallocations. If deallocate() was
5239 called with STAT= , then set STAT to the count. If deallocate
5240 was called with ERRMSG, then set ERRMG to a string. */
5243 tree gfc_int4_type_node = gfc_get_int_type (4);
5245 stat = gfc_create_var (gfc_int4_type_node, "stat");
5246 pstat = gfc_build_addr_expr (NULL_TREE, stat);
5248 /* GOTO destinations. */
5249 label_errmsg = gfc_build_label_decl (NULL_TREE);
5250 label_finish = gfc_build_label_decl (NULL_TREE);
5251 TREE_USED (label_finish) = 0;
5254 /* Set ERRMSG - only needed if STAT is available. */
5255 if (code->expr1 && code->expr2)
5257 gfc_init_se (&se, NULL);
5258 se.want_pointer = 1;
5259 gfc_conv_expr_lhs (&se, code->expr2);
5261 errlen = se.string_length;
5264 for (al = code->ext.alloc.list; al != NULL; al = al->next)
5266 gfc_expr *expr = gfc_copy_expr (al->expr);
5267 gcc_assert (expr->expr_type == EXPR_VARIABLE);
5269 if (expr->ts.type == BT_CLASS)
5270 gfc_add_data_component (expr);
5272 gfc_init_se (&se, NULL);
5273 gfc_start_block (&se.pre);
5275 se.want_pointer = 1;
5276 se.descriptor_only = 1;
5277 gfc_conv_expr (&se, expr);
5279 if (expr->rank || gfc_is_coarray (expr))
5281 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
5284 gfc_ref *last = NULL;
5285 for (ref = expr->ref; ref; ref = ref->next)
5286 if (ref->type == REF_COMPONENT)
5289 /* Do not deallocate the components of a derived type
5290 ultimate pointer component. */
5291 if (!(last && last->u.c.component->attr.pointer)
5292 && !(!last && expr->symtree->n.sym->attr.pointer))
5294 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
5296 gfc_add_expr_to_block (&se.pre, tmp);
5299 tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
5300 label_finish, expr);
5301 gfc_add_expr_to_block (&se.pre, tmp);
5305 tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
5307 gfc_add_expr_to_block (&se.pre, tmp);
5309 /* Set to zero after deallocation. */
5310 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5312 build_int_cst (TREE_TYPE (se.expr), 0));
5313 gfc_add_expr_to_block (&se.pre, tmp);
5315 if (al->expr->ts.type == BT_CLASS)
5317 /* Reset _vptr component to declared type. */
5318 gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
5319 gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
5320 gfc_add_vptr_component (lhs);
5321 rhs = gfc_lval_expr_from_sym (vtab);
5322 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5323 gfc_add_expr_to_block (&se.pre, tmp);
5324 gfc_free_expr (lhs);
5325 gfc_free_expr (rhs);
5333 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5334 build_int_cst (TREE_TYPE (stat), 0));
5335 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5336 gfc_unlikely (cond),
5337 build1_v (GOTO_EXPR, label_errmsg),
5338 build_empty_stmt (input_location));
5339 gfc_add_expr_to_block (&se.pre, tmp);
5342 tmp = gfc_finish_block (&se.pre);
5343 gfc_add_expr_to_block (&block, tmp);
5344 gfc_free_expr (expr);
5349 tmp = build1_v (LABEL_EXPR, label_errmsg);
5350 gfc_add_expr_to_block (&block, tmp);
5353 /* Set ERRMSG - only needed if STAT is available. */
5354 if (code->expr1 && code->expr2)
5356 const char *msg = "Attempt to deallocate an unallocated object";
5357 stmtblock_t errmsg_block;
5358 tree errmsg_str, slen, dlen, cond;
5360 gfc_init_block (&errmsg_block);
5362 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
5363 gfc_add_modify (&errmsg_block, errmsg_str,
5364 gfc_build_addr_expr (pchar_type_node,
5365 gfc_build_localized_cstring_const (msg)));
5366 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5367 dlen = gfc_get_expr_charlen (code->expr2);
5369 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
5370 slen, errmsg_str, gfc_default_character_kind);
5371 tmp = gfc_finish_block (&errmsg_block);
5373 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5374 build_int_cst (TREE_TYPE (stat), 0));
5375 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5376 gfc_unlikely (cond), tmp,
5377 build_empty_stmt (input_location));
5379 gfc_add_expr_to_block (&block, tmp);
5382 if (code->expr1 && TREE_USED (label_finish))
5384 tmp = build1_v (LABEL_EXPR, label_finish);
5385 gfc_add_expr_to_block (&block, tmp);
5391 gfc_init_se (&se, NULL);
5392 gfc_conv_expr_lhs (&se, code->expr1);
5393 tmp = convert (TREE_TYPE (se.expr), stat);
5394 gfc_add_modify (&block, se.expr, tmp);
5397 return gfc_finish_block (&block);
5400 #include "gt-fortran-trans-stmt.h"