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 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
182 elemental subroutines. Make temporaries for output arguments if any such
183 dependencies are found. Output arguments are chosen because internal_unpack
184 can be used, as is, to copy the result back to the variable. */
186 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
187 gfc_symbol * sym, gfc_actual_arglist * arg,
188 gfc_dep_check check_variable)
190 gfc_actual_arglist *arg0;
192 gfc_formal_arglist *formal;
193 gfc_loopinfo tmp_loop;
205 if (loopse->ss == NULL)
210 formal = sym->formal;
212 /* Loop over all the arguments testing for dependencies. */
213 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
219 /* Obtain the info structure for the current argument. */
221 for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
225 info = &ss->data.info;
229 /* If there is a dependency, create a temporary and use it
230 instead of the variable. */
231 fsym = formal ? formal->sym : NULL;
232 if (e->expr_type == EXPR_VARIABLE
234 && fsym->attr.intent != INTENT_IN
235 && gfc_check_fncall_dependency (e, fsym->attr.intent,
236 sym, arg0, check_variable))
238 tree initial, temptype;
239 stmtblock_t temp_post;
241 /* Make a local loopinfo for the temporary creation, so that
242 none of the other ss->info's have to be renormalized. */
243 gfc_init_loopinfo (&tmp_loop);
244 tmp_loop.dimen = info->dimen;
245 for (n = 0; n < info->dimen; n++)
247 tmp_loop.to[n] = loopse->loop->to[n];
248 tmp_loop.from[n] = loopse->loop->from[n];
249 tmp_loop.order[n] = loopse->loop->order[n];
252 /* Obtain the argument descriptor for unpacking. */
253 gfc_init_se (&parmse, NULL);
254 parmse.want_pointer = 1;
256 /* The scalarizer introduces some specific peculiarities when
257 handling elemental subroutines; the stride can be needed up to
258 the dim_array - 1, rather than dim_loop - 1 to calculate
259 offsets outside the loop. For this reason, we make sure that
260 the descriptor has the dimensionality of the array by converting
261 trailing elements into ranges with end = start. */
262 for (ref = e->ref; ref; ref = ref->next)
263 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
268 bool seen_range = false;
269 for (n = 0; n < ref->u.ar.dimen; n++)
271 if (ref->u.ar.dimen_type[n] == DIMEN_RANGE)
275 || ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
278 ref->u.ar.end[n] = gfc_copy_expr (ref->u.ar.start[n]);
279 ref->u.ar.dimen_type[n] = DIMEN_RANGE;
283 gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
284 gfc_add_block_to_block (&se->pre, &parmse.pre);
286 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
287 initialize the array temporary with a copy of the values. */
288 if (fsym->attr.intent == INTENT_INOUT
289 || (fsym->ts.type ==BT_DERIVED
290 && fsym->attr.intent == INTENT_OUT))
291 initial = parmse.expr;
295 /* Find the type of the temporary to create; we don't use the type
296 of e itself as this breaks for subcomponent-references in e (where
297 the type of e is that of the final reference, but parmse.expr's
298 type corresponds to the full derived-type). */
299 /* TODO: Fix this somehow so we don't need a temporary of the whole
300 array but instead only the components referenced. */
301 temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
302 gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
303 temptype = TREE_TYPE (temptype);
304 temptype = gfc_get_element_type (temptype);
306 /* Generate the temporary. Cleaning up the temporary should be the
307 very last thing done, so we add the code to a new block and add it
308 to se->post as last instructions. */
309 size = gfc_create_var (gfc_array_index_type, NULL);
310 data = gfc_create_var (pvoid_type_node, NULL);
311 gfc_init_block (&temp_post);
312 tmp = gfc_trans_create_temp_array (&se->pre, &temp_post,
313 &tmp_loop, ss, temptype,
317 gfc_add_modify (&se->pre, size, tmp);
318 tmp = fold_convert (pvoid_type_node, info->data);
319 gfc_add_modify (&se->pre, data, tmp);
321 /* Calculate the offset for the temporary. */
322 offset = gfc_index_zero_node;
323 for (n = 0; n < info->dimen; n++)
325 tmp = gfc_conv_descriptor_stride_get (info->descriptor,
327 tmp = fold_build2_loc (input_location, MULT_EXPR,
328 gfc_array_index_type,
329 loopse->loop->from[n], tmp);
330 offset = fold_build2_loc (input_location, MINUS_EXPR,
331 gfc_array_index_type, offset, tmp);
333 info->offset = gfc_create_var (gfc_array_index_type, NULL);
334 gfc_add_modify (&se->pre, info->offset, offset);
336 /* Copy the result back using unpack. */
337 tmp = build_call_expr_loc (input_location,
338 gfor_fndecl_in_unpack, 2, parmse.expr, data);
339 gfc_add_expr_to_block (&se->post, tmp);
341 /* parmse.pre is already added above. */
342 gfc_add_block_to_block (&se->post, &parmse.post);
343 gfc_add_block_to_block (&se->post, &temp_post);
349 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
352 gfc_trans_call (gfc_code * code, bool dependency_check,
353 tree mask, tree count1, bool invert)
357 int has_alternate_specifier;
358 gfc_dep_check check_variable;
359 tree index = NULL_TREE;
360 tree maskexpr = NULL_TREE;
363 /* A CALL starts a new block because the actual arguments may have to
364 be evaluated first. */
365 gfc_init_se (&se, NULL);
366 gfc_start_block (&se.pre);
368 gcc_assert (code->resolved_sym);
370 ss = gfc_ss_terminator;
371 if (code->resolved_sym->attr.elemental)
372 ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
374 /* Is not an elemental subroutine call with array valued arguments. */
375 if (ss == gfc_ss_terminator)
378 /* Translate the call. */
379 has_alternate_specifier
380 = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
383 /* A subroutine without side-effect, by definition, does nothing! */
384 TREE_SIDE_EFFECTS (se.expr) = 1;
386 /* Chain the pieces together and return the block. */
387 if (has_alternate_specifier)
389 gfc_code *select_code;
391 select_code = code->next;
392 gcc_assert(select_code->op == EXEC_SELECT);
393 sym = select_code->expr1->symtree->n.sym;
394 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
395 if (sym->backend_decl == NULL)
396 sym->backend_decl = gfc_get_symbol_decl (sym);
397 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
400 gfc_add_expr_to_block (&se.pre, se.expr);
402 gfc_add_block_to_block (&se.pre, &se.post);
407 /* An elemental subroutine call with array valued arguments has
415 /* gfc_walk_elemental_function_args renders the ss chain in the
416 reverse order to the actual argument order. */
417 ss = gfc_reverse_ss (ss);
419 /* Initialize the loop. */
420 gfc_init_se (&loopse, NULL);
421 gfc_init_loopinfo (&loop);
422 gfc_add_ss_to_loop (&loop, ss);
424 gfc_conv_ss_startstride (&loop);
425 /* TODO: gfc_conv_loop_setup generates a temporary for vector
426 subscripts. This could be prevented in the elemental case
427 as temporaries are handled separatedly
428 (below in gfc_conv_elemental_dependencies). */
429 gfc_conv_loop_setup (&loop, &code->expr1->where);
430 gfc_mark_ss_chain_used (ss, 1);
432 /* Convert the arguments, checking for dependencies. */
433 gfc_copy_loopinfo_to_se (&loopse, &loop);
436 /* For operator assignment, do dependency checking. */
437 if (dependency_check)
438 check_variable = ELEM_CHECK_VARIABLE;
440 check_variable = ELEM_DONT_CHECK_VARIABLE;
442 gfc_init_se (&depse, NULL);
443 gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
444 code->ext.actual, check_variable);
446 gfc_add_block_to_block (&loop.pre, &depse.pre);
447 gfc_add_block_to_block (&loop.post, &depse.post);
449 /* Generate the loop body. */
450 gfc_start_scalarized_body (&loop, &body);
451 gfc_init_block (&block);
455 /* Form the mask expression according to the mask. */
457 maskexpr = gfc_build_array_ref (mask, index, NULL);
459 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
460 TREE_TYPE (maskexpr), maskexpr);
463 /* Add the subroutine call to the block. */
464 gfc_conv_procedure_call (&loopse, code->resolved_sym,
465 code->ext.actual, code->expr1, NULL);
469 tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
470 build_empty_stmt (input_location));
471 gfc_add_expr_to_block (&loopse.pre, tmp);
472 tmp = fold_build2_loc (input_location, PLUS_EXPR,
473 gfc_array_index_type,
474 count1, gfc_index_one_node);
475 gfc_add_modify (&loopse.pre, count1, tmp);
478 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
480 gfc_add_block_to_block (&block, &loopse.pre);
481 gfc_add_block_to_block (&block, &loopse.post);
483 /* Finish up the loop block and the loop. */
484 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
485 gfc_trans_scalarizing_loops (&loop, &body);
486 gfc_add_block_to_block (&se.pre, &loop.pre);
487 gfc_add_block_to_block (&se.pre, &loop.post);
488 gfc_add_block_to_block (&se.pre, &se.post);
489 gfc_cleanup_loop (&loop);
492 return gfc_finish_block (&se.pre);
496 /* Translate the RETURN statement. */
499 gfc_trans_return (gfc_code * code)
507 /* If code->expr is not NULL, this return statement must appear
508 in a subroutine and current_fake_result_decl has already
511 result = gfc_get_fake_result_decl (NULL, 0);
514 gfc_warning ("An alternate return at %L without a * dummy argument",
515 &code->expr1->where);
516 return gfc_generate_return ();
519 /* Start a new block for this statement. */
520 gfc_init_se (&se, NULL);
521 gfc_start_block (&se.pre);
523 gfc_conv_expr (&se, code->expr1);
525 /* Note that the actually returned expression is a simple value and
526 does not depend on any pointers or such; thus we can clean-up with
527 se.post before returning. */
528 tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
529 result, fold_convert (TREE_TYPE (result),
531 gfc_add_expr_to_block (&se.pre, tmp);
532 gfc_add_block_to_block (&se.pre, &se.post);
534 tmp = gfc_generate_return ();
535 gfc_add_expr_to_block (&se.pre, tmp);
536 return gfc_finish_block (&se.pre);
539 return gfc_generate_return ();
543 /* Translate the PAUSE statement. We have to translate this statement
544 to a runtime library call. */
547 gfc_trans_pause (gfc_code * code)
549 tree gfc_int4_type_node = gfc_get_int_type (4);
553 /* Start a new block for this statement. */
554 gfc_init_se (&se, NULL);
555 gfc_start_block (&se.pre);
558 if (code->expr1 == NULL)
560 tmp = build_int_cst (gfc_int4_type_node, 0);
561 tmp = build_call_expr_loc (input_location,
562 gfor_fndecl_pause_string, 2,
563 build_int_cst (pchar_type_node, 0), tmp);
565 else if (code->expr1->ts.type == BT_INTEGER)
567 gfc_conv_expr (&se, code->expr1);
568 tmp = build_call_expr_loc (input_location,
569 gfor_fndecl_pause_numeric, 1,
570 fold_convert (gfc_int4_type_node, se.expr));
574 gfc_conv_expr_reference (&se, code->expr1);
575 tmp = build_call_expr_loc (input_location,
576 gfor_fndecl_pause_string, 2,
577 se.expr, se.string_length);
580 gfc_add_expr_to_block (&se.pre, tmp);
582 gfc_add_block_to_block (&se.pre, &se.post);
584 return gfc_finish_block (&se.pre);
588 /* Translate the STOP statement. We have to translate this statement
589 to a runtime library call. */
592 gfc_trans_stop (gfc_code *code, bool error_stop)
594 tree gfc_int4_type_node = gfc_get_int_type (4);
598 /* Start a new block for this statement. */
599 gfc_init_se (&se, NULL);
600 gfc_start_block (&se.pre);
602 if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
604 /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
605 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
606 tmp = build_call_expr_loc (input_location, tmp, 0);
607 gfc_add_expr_to_block (&se.pre, tmp);
609 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
610 gfc_add_expr_to_block (&se.pre, tmp);
613 if (code->expr1 == NULL)
615 tmp = build_int_cst (gfc_int4_type_node, 0);
616 tmp = build_call_expr_loc (input_location,
618 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
619 ? gfor_fndecl_caf_error_stop_str
620 : gfor_fndecl_error_stop_string)
621 : gfor_fndecl_stop_string,
622 2, build_int_cst (pchar_type_node, 0), tmp);
624 else if (code->expr1->ts.type == BT_INTEGER)
626 gfc_conv_expr (&se, code->expr1);
627 tmp = build_call_expr_loc (input_location,
629 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
630 ? gfor_fndecl_caf_error_stop
631 : gfor_fndecl_error_stop_numeric)
632 : gfor_fndecl_stop_numeric_f08, 1,
633 fold_convert (gfc_int4_type_node, se.expr));
637 gfc_conv_expr_reference (&se, code->expr1);
638 tmp = build_call_expr_loc (input_location,
640 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
641 ? gfor_fndecl_caf_error_stop_str
642 : gfor_fndecl_error_stop_string)
643 : gfor_fndecl_stop_string,
644 2, se.expr, se.string_length);
647 gfc_add_expr_to_block (&se.pre, tmp);
649 gfc_add_block_to_block (&se.pre, &se.post);
651 return gfc_finish_block (&se.pre);
656 gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
659 tree stat = NULL_TREE, lock_acquired = NULL_TREE;
661 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
662 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
663 if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
666 gfc_init_se (&se, NULL);
667 gfc_start_block (&se.pre);
671 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
672 gfc_init_se (&argse, NULL);
673 gfc_conv_expr_val (&argse, code->expr2);
679 gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
680 gfc_init_se (&argse, NULL);
681 gfc_conv_expr_val (&argse, code->expr4);
682 lock_acquired = argse.expr;
685 if (stat != NULL_TREE)
686 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
688 if (lock_acquired != NULL_TREE)
689 gfc_add_modify (&se.pre, lock_acquired,
690 fold_convert (TREE_TYPE (lock_acquired),
693 return gfc_finish_block (&se.pre);
698 gfc_trans_sync (gfc_code *code, gfc_exec_op type)
702 tree images = NULL_TREE, stat = NULL_TREE,
703 errmsg = NULL_TREE, errmsglen = NULL_TREE;
705 /* Short cut: For single images without bound checking or without STAT=,
706 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
707 if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
708 && gfc_option.coarray != GFC_FCOARRAY_LIB)
711 gfc_init_se (&se, NULL);
712 gfc_start_block (&se.pre);
714 if (code->expr1 && code->expr1->rank == 0)
716 gfc_init_se (&argse, NULL);
717 gfc_conv_expr_val (&argse, code->expr1);
723 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
724 gfc_init_se (&argse, NULL);
725 gfc_conv_expr_val (&argse, code->expr2);
729 stat = null_pointer_node;
731 if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
732 && type != EXEC_SYNC_MEMORY)
734 gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
735 gfc_init_se (&argse, NULL);
736 gfc_conv_expr (&argse, code->expr3);
737 gfc_conv_string_parameter (&argse);
738 errmsg = gfc_build_addr_expr (NULL, argse.expr);
739 errmsglen = argse.string_length;
741 else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
743 errmsg = null_pointer_node;
744 errmsglen = build_int_cst (integer_type_node, 0);
747 /* Check SYNC IMAGES(imageset) for valid image index.
748 FIXME: Add a check for image-set arrays. */
749 if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
750 && code->expr1->rank == 0)
753 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
754 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
755 images, build_int_cst (TREE_TYPE (images), 1));
759 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
760 images, gfort_gvar_caf_num_images);
761 cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
763 build_int_cst (TREE_TYPE (images), 1));
764 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
765 boolean_type_node, cond, cond2);
767 gfc_trans_runtime_check (true, false, cond, &se.pre,
768 &code->expr1->where, "Invalid image number "
770 fold_convert (integer_type_node, se.expr));
773 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
774 image control statements SYNC IMAGES and SYNC ALL. */
775 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
777 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
778 tmp = build_call_expr_loc (input_location, tmp, 0);
779 gfc_add_expr_to_block (&se.pre, tmp);
782 if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
784 /* Set STAT to zero. */
786 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
788 else if (type == EXEC_SYNC_ALL)
790 /* SYNC ALL => stat == null_pointer_node
791 SYNC ALL(stat=s) => stat has an integer type
793 If "stat" has the wrong integer type, use a temp variable of
794 the right type and later cast the result back into "stat". */
795 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
797 if (TREE_TYPE (stat) == integer_type_node)
798 stat = gfc_build_addr_expr (NULL, stat);
800 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
801 3, stat, errmsg, errmsglen);
802 gfc_add_expr_to_block (&se.pre, tmp);
806 tree tmp_stat = gfc_create_var (integer_type_node, "stat");
808 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
809 3, gfc_build_addr_expr (NULL, tmp_stat),
811 gfc_add_expr_to_block (&se.pre, tmp);
813 gfc_add_modify (&se.pre, stat,
814 fold_convert (TREE_TYPE (stat), tmp_stat));
821 gcc_assert (type == EXEC_SYNC_IMAGES);
825 len = build_int_cst (integer_type_node, -1);
826 images = null_pointer_node;
828 else if (code->expr1->rank == 0)
830 len = build_int_cst (integer_type_node, 1);
831 images = gfc_build_addr_expr (NULL_TREE, images);
836 if (code->expr1->ts.kind != gfc_c_int_kind)
837 gfc_fatal_error ("Sorry, only support for integer kind %d "
838 "implemented for image-set at %L",
839 gfc_c_int_kind, &code->expr1->where);
841 gfc_conv_array_parameter (&se, code->expr1,
842 gfc_walk_expr (code->expr1), true, NULL,
846 tmp = gfc_typenode_for_spec (&code->expr1->ts);
847 if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
848 tmp = gfc_get_element_type (tmp);
850 len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
851 TREE_TYPE (len), len,
852 fold_convert (TREE_TYPE (len),
853 TYPE_SIZE_UNIT (tmp)));
854 len = fold_convert (integer_type_node, len);
857 /* SYNC IMAGES(imgs) => stat == null_pointer_node
858 SYNC IMAGES(imgs,stat=s) => stat has an integer type
860 If "stat" has the wrong integer type, use a temp variable of
861 the right type and later cast the result back into "stat". */
862 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
864 if (TREE_TYPE (stat) == integer_type_node)
865 stat = gfc_build_addr_expr (NULL, stat);
867 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
868 5, fold_convert (integer_type_node, len),
869 images, stat, errmsg, errmsglen);
870 gfc_add_expr_to_block (&se.pre, tmp);
874 tree tmp_stat = gfc_create_var (integer_type_node, "stat");
876 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
877 5, fold_convert (integer_type_node, len),
878 images, gfc_build_addr_expr (NULL, tmp_stat),
880 gfc_add_expr_to_block (&se.pre, tmp);
882 gfc_add_modify (&se.pre, stat,
883 fold_convert (TREE_TYPE (stat), tmp_stat));
887 return gfc_finish_block (&se.pre);
891 /* Generate GENERIC for the IF construct. This function also deals with
892 the simple IF statement, because the front end translates the IF
893 statement into an IF construct.
925 where COND_S is the simplified version of the predicate. PRE_COND_S
926 are the pre side-effects produced by the translation of the
928 We need to build the chain recursively otherwise we run into
929 problems with folding incomplete statements. */
932 gfc_trans_if_1 (gfc_code * code)
939 /* Check for an unconditional ELSE clause. */
941 return gfc_trans_code (code->next);
943 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
944 gfc_init_se (&if_se, NULL);
945 gfc_start_block (&if_se.pre);
947 /* Calculate the IF condition expression. */
948 if (code->expr1->where.lb)
950 gfc_save_backend_locus (&saved_loc);
951 gfc_set_backend_locus (&code->expr1->where);
954 gfc_conv_expr_val (&if_se, code->expr1);
956 if (code->expr1->where.lb)
957 gfc_restore_backend_locus (&saved_loc);
959 /* Translate the THEN clause. */
960 stmt = gfc_trans_code (code->next);
962 /* Translate the ELSE clause. */
964 elsestmt = gfc_trans_if_1 (code->block);
966 elsestmt = build_empty_stmt (input_location);
968 /* Build the condition expression and add it to the condition block. */
969 loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
970 stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
973 gfc_add_expr_to_block (&if_se.pre, stmt);
975 /* Finish off this statement. */
976 return gfc_finish_block (&if_se.pre);
980 gfc_trans_if (gfc_code * code)
985 /* Create exit label so it is available for trans'ing the body code. */
986 exit_label = gfc_build_label_decl (NULL_TREE);
987 code->exit_label = exit_label;
989 /* Translate the actual code in code->block. */
990 gfc_init_block (&body);
991 gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
993 /* Add exit label. */
994 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
996 return gfc_finish_block (&body);
1000 /* Translate an arithmetic IF expression.
1002 IF (cond) label1, label2, label3 translates to
1014 An optimized version can be generated in case of equal labels.
1015 E.g., if label1 is equal to label2, we can translate it to
1024 gfc_trans_arithmetic_if (gfc_code * code)
1032 /* Start a new block. */
1033 gfc_init_se (&se, NULL);
1034 gfc_start_block (&se.pre);
1036 /* Pre-evaluate COND. */
1037 gfc_conv_expr_val (&se, code->expr1);
1038 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1040 /* Build something to compare with. */
1041 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
1043 if (code->label1->value != code->label2->value)
1045 /* If (cond < 0) take branch1 else take branch2.
1046 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1047 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1048 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
1050 if (code->label1->value != code->label3->value)
1051 tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1054 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1057 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1058 tmp, branch1, branch2);
1061 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1063 if (code->label1->value != code->label3->value
1064 && code->label2->value != code->label3->value)
1066 /* if (cond <= 0) take branch1 else take branch2. */
1067 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
1068 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1070 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1071 tmp, branch1, branch2);
1074 /* Append the COND_EXPR to the evaluation of COND, and return. */
1075 gfc_add_expr_to_block (&se.pre, branch1);
1076 return gfc_finish_block (&se.pre);
1080 /* Translate a CRITICAL block. */
1082 gfc_trans_critical (gfc_code *code)
1087 gfc_start_block (&block);
1089 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1091 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
1092 gfc_add_expr_to_block (&block, tmp);
1095 tmp = gfc_trans_code (code->block->next);
1096 gfc_add_expr_to_block (&block, tmp);
1098 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1100 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
1102 gfc_add_expr_to_block (&block, tmp);
1106 return gfc_finish_block (&block);
1110 /* Do proper initialization for ASSOCIATE names. */
1113 trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
1118 gcc_assert (sym->assoc);
1119 e = sym->assoc->target;
1121 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1122 to array temporary) for arrays with either unknown shape or if associating
1124 if (sym->attr.dimension
1125 && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
1131 desc = sym->backend_decl;
1133 /* If association is to an expression, evaluate it and create temporary.
1134 Otherwise, get descriptor of target for pointer assignment. */
1135 gfc_init_se (&se, NULL);
1136 ss = gfc_walk_expr (e);
1137 if (sym->assoc->variable)
1139 se.direct_byref = 1;
1142 gfc_conv_expr_descriptor (&se, e, ss);
1144 /* If we didn't already do the pointer assignment, set associate-name
1145 descriptor to the one generated for the temporary. */
1146 if (!sym->assoc->variable)
1150 gfc_add_modify (&se.pre, desc, se.expr);
1152 /* The generated descriptor has lower bound zero (as array
1153 temporary), shift bounds so we get lower bounds of 1. */
1154 for (dim = 0; dim < e->rank; ++dim)
1155 gfc_conv_shift_descriptor_lbound (&se.pre, desc,
1156 dim, gfc_index_one_node);
1159 /* Done, register stuff as init / cleanup code. */
1160 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
1161 gfc_finish_block (&se.post));
1164 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1165 else if (gfc_is_associate_pointer (sym))
1169 gcc_assert (!sym->attr.dimension);
1171 gfc_init_se (&se, NULL);
1172 gfc_conv_expr (&se, e);
1174 tmp = TREE_TYPE (sym->backend_decl);
1175 tmp = gfc_build_addr_expr (tmp, se.expr);
1176 gfc_add_modify (&se.pre, sym->backend_decl, tmp);
1178 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1179 gfc_finish_block (&se.post));
1182 /* Do a simple assignment. This is for scalar expressions, where we
1183 can simply use expression assignment. */
1188 lhs = gfc_lval_expr_from_sym (sym);
1189 tmp = gfc_trans_assignment (lhs, e, false, true);
1190 gfc_add_init_cleanup (block, tmp, NULL_TREE);
1195 /* Translate a BLOCK construct. This is basically what we would do for a
1199 gfc_trans_block_construct (gfc_code* code)
1203 gfc_wrapped_block block;
1206 gfc_association_list *ass;
1208 ns = code->ext.block.ns;
1210 sym = ns->proc_name;
1213 /* Process local variables. */
1214 gcc_assert (!sym->tlink);
1216 gfc_process_block_locals (ns);
1218 /* Generate code including exit-label. */
1219 gfc_init_block (&body);
1220 exit_label = gfc_build_label_decl (NULL_TREE);
1221 code->exit_label = exit_label;
1222 gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
1223 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1225 /* Finish everything. */
1226 gfc_start_wrapped_block (&block, gfc_finish_block (&body));
1227 gfc_trans_deferred_vars (sym, &block);
1228 for (ass = code->ext.block.assoc; ass; ass = ass->next)
1229 trans_associate_var (ass->st->n.sym, &block);
1231 return gfc_finish_wrapped_block (&block);
1235 /* Translate the simple DO construct. This is where the loop variable has
1236 integer type and step +-1. We can't use this in the general case
1237 because integer overflow and floating point errors could give incorrect
1239 We translate a do loop from:
1241 DO dovar = from, to, step
1247 [Evaluate loop bounds and step]
1249 if ((step > 0) ? (dovar <= to) : (dovar => to))
1255 cond = (dovar == to);
1257 if (cond) goto end_label;
1262 This helps the optimizers by avoiding the extra induction variable
1263 used in the general case. */
1266 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
1267 tree from, tree to, tree step, tree exit_cond)
1273 tree saved_dovar = NULL;
1278 type = TREE_TYPE (dovar);
1280 loc = code->ext.iterator->start->where.lb->location;
1282 /* Initialize the DO variable: dovar = from. */
1283 gfc_add_modify_loc (loc, pblock, dovar, from);
1285 /* Save value for do-tinkering checking. */
1286 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1288 saved_dovar = gfc_create_var (type, ".saved_dovar");
1289 gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
1292 /* Cycle and exit statements are implemented with gotos. */
1293 cycle_label = gfc_build_label_decl (NULL_TREE);
1294 exit_label = gfc_build_label_decl (NULL_TREE);
1296 /* Put the labels where they can be found later. See gfc_trans_do(). */
1297 code->cycle_label = cycle_label;
1298 code->exit_label = exit_label;
1301 gfc_start_block (&body);
1303 /* Main loop body. */
1304 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1305 gfc_add_expr_to_block (&body, tmp);
1307 /* Label for cycle statements (if needed). */
1308 if (TREE_USED (cycle_label))
1310 tmp = build1_v (LABEL_EXPR, cycle_label);
1311 gfc_add_expr_to_block (&body, tmp);
1314 /* Check whether someone has modified the loop variable. */
1315 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1317 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
1318 dovar, saved_dovar);
1319 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1320 "Loop variable has been modified");
1323 /* Exit the loop if there is an I/O result condition or error. */
1326 tmp = build1_v (GOTO_EXPR, exit_label);
1327 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1329 build_empty_stmt (loc));
1330 gfc_add_expr_to_block (&body, tmp);
1333 /* Evaluate the loop condition. */
1334 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
1336 cond = gfc_evaluate_now_loc (loc, cond, &body);
1338 /* Increment the loop variable. */
1339 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1340 gfc_add_modify_loc (loc, &body, dovar, tmp);
1342 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1343 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1345 /* The loop exit. */
1346 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1347 TREE_USED (exit_label) = 1;
1348 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1349 cond, tmp, build_empty_stmt (loc));
1350 gfc_add_expr_to_block (&body, tmp);
1352 /* Finish the loop body. */
1353 tmp = gfc_finish_block (&body);
1354 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1356 /* Only execute the loop if the number of iterations is positive. */
1357 if (tree_int_cst_sgn (step) > 0)
1358 cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
1361 cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
1363 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
1364 build_empty_stmt (loc));
1365 gfc_add_expr_to_block (pblock, tmp);
1367 /* Add the exit label. */
1368 tmp = build1_v (LABEL_EXPR, exit_label);
1369 gfc_add_expr_to_block (pblock, tmp);
1371 return gfc_finish_block (pblock);
1374 /* Translate the DO construct. This obviously is one of the most
1375 important ones to get right with any compiler, but especially
1378 We special case some loop forms as described in gfc_trans_simple_do.
1379 For other cases we implement them with a separate loop count,
1380 as described in the standard.
1382 We translate a do loop from:
1384 DO dovar = from, to, step
1390 [evaluate loop bounds and step]
1391 empty = (step > 0 ? to < from : to > from);
1392 countm1 = (to - from) / step;
1394 if (empty) goto exit_label;
1400 if (countm1 ==0) goto exit_label;
1405 countm1 is an unsigned integer. It is equal to the loop count minus one,
1406 because the loop count itself can overflow. */
1409 gfc_trans_do (gfc_code * code, tree exit_cond)
1413 tree saved_dovar = NULL;
1429 gfc_start_block (&block);
1431 loc = code->ext.iterator->start->where.lb->location;
1433 /* Evaluate all the expressions in the iterator. */
1434 gfc_init_se (&se, NULL);
1435 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1436 gfc_add_block_to_block (&block, &se.pre);
1438 type = TREE_TYPE (dovar);
1440 gfc_init_se (&se, NULL);
1441 gfc_conv_expr_val (&se, code->ext.iterator->start);
1442 gfc_add_block_to_block (&block, &se.pre);
1443 from = gfc_evaluate_now (se.expr, &block);
1445 gfc_init_se (&se, NULL);
1446 gfc_conv_expr_val (&se, code->ext.iterator->end);
1447 gfc_add_block_to_block (&block, &se.pre);
1448 to = gfc_evaluate_now (se.expr, &block);
1450 gfc_init_se (&se, NULL);
1451 gfc_conv_expr_val (&se, code->ext.iterator->step);
1452 gfc_add_block_to_block (&block, &se.pre);
1453 step = gfc_evaluate_now (se.expr, &block);
1455 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1457 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
1458 build_zero_cst (type));
1459 gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
1460 "DO step value is zero");
1463 /* Special case simple loops. */
1464 if (TREE_CODE (type) == INTEGER_TYPE
1465 && (integer_onep (step)
1466 || tree_int_cst_equal (step, integer_minus_one_node)))
1467 return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
1469 pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
1470 build_zero_cst (type));
1472 if (TREE_CODE (type) == INTEGER_TYPE)
1473 utype = unsigned_type_for (type);
1475 utype = unsigned_type_for (gfc_array_index_type);
1476 countm1 = gfc_create_var (utype, "countm1");
1478 /* Cycle and exit statements are implemented with gotos. */
1479 cycle_label = gfc_build_label_decl (NULL_TREE);
1480 exit_label = gfc_build_label_decl (NULL_TREE);
1481 TREE_USED (exit_label) = 1;
1483 /* Put these labels where they can be found later. */
1484 code->cycle_label = cycle_label;
1485 code->exit_label = exit_label;
1487 /* Initialize the DO variable: dovar = from. */
1488 gfc_add_modify (&block, dovar, from);
1490 /* Save value for do-tinkering checking. */
1491 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1493 saved_dovar = gfc_create_var (type, ".saved_dovar");
1494 gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
1497 /* Initialize loop count and jump to exit label if the loop is empty.
1498 This code is executed before we enter the loop body. We generate:
1499 step_sign = sign(1,step);
1510 countm1 = (to*step_sign - from*step_sign) / (step*step_sign);
1514 if (TREE_CODE (type) == INTEGER_TYPE)
1516 tree pos, neg, step_sign, to2, from2, step2;
1518 /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */
1520 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
1521 build_int_cst (TREE_TYPE (step), 0));
1522 step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
1523 build_int_cst (type, -1),
1524 build_int_cst (type, 1));
1526 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
1527 pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1528 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1530 build_empty_stmt (loc));
1532 tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to,
1534 neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1535 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1537 build_empty_stmt (loc));
1538 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1539 pos_step, pos, neg);
1541 gfc_add_expr_to_block (&block, tmp);
1543 /* Calculate the loop count. to-from can overflow, so
1544 we cast to unsigned. */
1546 to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to);
1547 from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from);
1548 step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step);
1549 step2 = fold_convert (utype, step2);
1550 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2);
1551 tmp = fold_convert (utype, tmp);
1552 tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2);
1553 tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp);
1554 gfc_add_expr_to_block (&block, tmp);
1558 /* TODO: We could use the same width as the real type.
1559 This would probably cause more problems that it solves
1560 when we implement "long double" types. */
1562 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
1563 tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
1564 tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
1565 gfc_add_modify (&block, countm1, tmp);
1567 /* We need a special check for empty loops:
1568 empty = (step > 0 ? to < from : to > from); */
1569 tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
1570 fold_build2_loc (loc, LT_EXPR,
1571 boolean_type_node, to, from),
1572 fold_build2_loc (loc, GT_EXPR,
1573 boolean_type_node, to, from));
1574 /* If the loop is empty, go directly to the exit label. */
1575 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1576 build1_v (GOTO_EXPR, exit_label),
1577 build_empty_stmt (input_location));
1578 gfc_add_expr_to_block (&block, tmp);
1582 gfc_start_block (&body);
1584 /* Main loop body. */
1585 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1586 gfc_add_expr_to_block (&body, tmp);
1588 /* Label for cycle statements (if needed). */
1589 if (TREE_USED (cycle_label))
1591 tmp = build1_v (LABEL_EXPR, cycle_label);
1592 gfc_add_expr_to_block (&body, tmp);
1595 /* Check whether someone has modified the loop variable. */
1596 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1598 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
1600 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1601 "Loop variable has been modified");
1604 /* Exit the loop if there is an I/O result condition or error. */
1607 tmp = build1_v (GOTO_EXPR, exit_label);
1608 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1610 build_empty_stmt (input_location));
1611 gfc_add_expr_to_block (&body, tmp);
1614 /* Increment the loop variable. */
1615 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1616 gfc_add_modify_loc (loc, &body, dovar, tmp);
1618 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1619 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1621 /* End with the loop condition. Loop until countm1 == 0. */
1622 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1,
1623 build_int_cst (utype, 0));
1624 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1625 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1626 cond, tmp, build_empty_stmt (loc));
1627 gfc_add_expr_to_block (&body, tmp);
1629 /* Decrement the loop count. */
1630 tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
1631 build_int_cst (utype, 1));
1632 gfc_add_modify_loc (loc, &body, countm1, tmp);
1634 /* End of loop body. */
1635 tmp = gfc_finish_block (&body);
1637 /* The for loop itself. */
1638 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1639 gfc_add_expr_to_block (&block, tmp);
1641 /* Add the exit label. */
1642 tmp = build1_v (LABEL_EXPR, exit_label);
1643 gfc_add_expr_to_block (&block, tmp);
1645 return gfc_finish_block (&block);
1649 /* Translate the DO WHILE construct.
1662 if (! cond) goto exit_label;
1668 Because the evaluation of the exit condition `cond' may have side
1669 effects, we can't do much for empty loop bodies. The backend optimizers
1670 should be smart enough to eliminate any dead loops. */
1673 gfc_trans_do_while (gfc_code * code)
1681 /* Everything we build here is part of the loop body. */
1682 gfc_start_block (&block);
1684 /* Cycle and exit statements are implemented with gotos. */
1685 cycle_label = gfc_build_label_decl (NULL_TREE);
1686 exit_label = gfc_build_label_decl (NULL_TREE);
1688 /* Put the labels where they can be found later. See gfc_trans_do(). */
1689 code->cycle_label = cycle_label;
1690 code->exit_label = exit_label;
1692 /* Create a GIMPLE version of the exit condition. */
1693 gfc_init_se (&cond, NULL);
1694 gfc_conv_expr_val (&cond, code->expr1);
1695 gfc_add_block_to_block (&block, &cond.pre);
1696 cond.expr = fold_build1_loc (code->expr1->where.lb->location,
1697 TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
1699 /* Build "IF (! cond) GOTO exit_label". */
1700 tmp = build1_v (GOTO_EXPR, exit_label);
1701 TREE_USED (exit_label) = 1;
1702 tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
1703 void_type_node, cond.expr, tmp,
1704 build_empty_stmt (code->expr1->where.lb->location));
1705 gfc_add_expr_to_block (&block, tmp);
1707 /* The main body of the loop. */
1708 tmp = gfc_trans_code (code->block->next);
1709 gfc_add_expr_to_block (&block, tmp);
1711 /* Label for cycle statements (if needed). */
1712 if (TREE_USED (cycle_label))
1714 tmp = build1_v (LABEL_EXPR, cycle_label);
1715 gfc_add_expr_to_block (&block, tmp);
1718 /* End of loop body. */
1719 tmp = gfc_finish_block (&block);
1721 gfc_init_block (&block);
1722 /* Build the loop. */
1723 tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
1724 void_type_node, tmp);
1725 gfc_add_expr_to_block (&block, tmp);
1727 /* Add the exit label. */
1728 tmp = build1_v (LABEL_EXPR, exit_label);
1729 gfc_add_expr_to_block (&block, tmp);
1731 return gfc_finish_block (&block);
1735 /* Translate the SELECT CASE construct for INTEGER case expressions,
1736 without killing all potential optimizations. The problem is that
1737 Fortran allows unbounded cases, but the back-end does not, so we
1738 need to intercept those before we enter the equivalent SWITCH_EXPR
1741 For example, we translate this,
1744 CASE (:100,101,105:115)
1754 to the GENERIC equivalent,
1758 case (minimum value for typeof(expr) ... 100:
1764 case 200 ... (maximum value for typeof(expr):
1781 gfc_trans_integer_select (gfc_code * code)
1791 gfc_start_block (&block);
1793 /* Calculate the switch expression. */
1794 gfc_init_se (&se, NULL);
1795 gfc_conv_expr_val (&se, code->expr1);
1796 gfc_add_block_to_block (&block, &se.pre);
1798 end_label = gfc_build_label_decl (NULL_TREE);
1800 gfc_init_block (&body);
1802 for (c = code->block; c; c = c->block)
1804 for (cp = c->ext.block.case_list; cp; cp = cp->next)
1809 /* Assume it's the default case. */
1810 low = high = NULL_TREE;
1814 low = gfc_conv_mpz_to_tree (cp->low->value.integer,
1817 /* If there's only a lower bound, set the high bound to the
1818 maximum value of the case expression. */
1820 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1825 /* Three cases are possible here:
1827 1) There is no lower bound, e.g. CASE (:N).
1828 2) There is a lower bound .NE. high bound, that is
1829 a case range, e.g. CASE (N:M) where M>N (we make
1830 sure that M>N during type resolution).
1831 3) There is a lower bound, and it has the same value
1832 as the high bound, e.g. CASE (N:N). This is our
1833 internal representation of CASE(N).
1835 In the first and second case, we need to set a value for
1836 high. In the third case, we don't because the GCC middle
1837 end represents a single case value by just letting high be
1838 a NULL_TREE. We can't do that because we need to be able
1839 to represent unbounded cases. */
1843 && mpz_cmp (cp->low->value.integer,
1844 cp->high->value.integer) != 0))
1845 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
1848 /* Unbounded case. */
1850 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1853 /* Build a label. */
1854 label = gfc_build_label_decl (NULL_TREE);
1856 /* Add this case label.
1857 Add parameter 'label', make it match GCC backend. */
1858 tmp = build_case_label (low, high, label);
1859 gfc_add_expr_to_block (&body, tmp);
1862 /* Add the statements for this case. */
1863 tmp = gfc_trans_code (c->next);
1864 gfc_add_expr_to_block (&body, tmp);
1866 /* Break to the end of the construct. */
1867 tmp = build1_v (GOTO_EXPR, end_label);
1868 gfc_add_expr_to_block (&body, tmp);
1871 tmp = gfc_finish_block (&body);
1872 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1873 gfc_add_expr_to_block (&block, tmp);
1875 tmp = build1_v (LABEL_EXPR, end_label);
1876 gfc_add_expr_to_block (&block, tmp);
1878 return gfc_finish_block (&block);
1882 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1884 There are only two cases possible here, even though the standard
1885 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1886 .FALSE., and DEFAULT.
1888 We never generate more than two blocks here. Instead, we always
1889 try to eliminate the DEFAULT case. This way, we can translate this
1890 kind of SELECT construct to a simple
1894 expression in GENERIC. */
1897 gfc_trans_logical_select (gfc_code * code)
1900 gfc_code *t, *f, *d;
1905 /* Assume we don't have any cases at all. */
1908 /* Now see which ones we actually do have. We can have at most two
1909 cases in a single case list: one for .TRUE. and one for .FALSE.
1910 The default case is always separate. If the cases for .TRUE. and
1911 .FALSE. are in the same case list, the block for that case list
1912 always executed, and we don't generate code a COND_EXPR. */
1913 for (c = code->block; c; c = c->block)
1915 for (cp = c->ext.block.case_list; cp; cp = cp->next)
1919 if (cp->low->value.logical == 0) /* .FALSE. */
1921 else /* if (cp->value.logical != 0), thus .TRUE. */
1929 /* Start a new block. */
1930 gfc_start_block (&block);
1932 /* Calculate the switch expression. We always need to do this
1933 because it may have side effects. */
1934 gfc_init_se (&se, NULL);
1935 gfc_conv_expr_val (&se, code->expr1);
1936 gfc_add_block_to_block (&block, &se.pre);
1938 if (t == f && t != NULL)
1940 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1941 translate the code for these cases, append it to the current
1943 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1947 tree true_tree, false_tree, stmt;
1949 true_tree = build_empty_stmt (input_location);
1950 false_tree = build_empty_stmt (input_location);
1952 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1953 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1954 make the missing case the default case. */
1955 if (t != NULL && f != NULL)
1965 /* Translate the code for each of these blocks, and append it to
1966 the current block. */
1968 true_tree = gfc_trans_code (t->next);
1971 false_tree = gfc_trans_code (f->next);
1973 stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1974 se.expr, true_tree, false_tree);
1975 gfc_add_expr_to_block (&block, stmt);
1978 return gfc_finish_block (&block);
1982 /* The jump table types are stored in static variables to avoid
1983 constructing them from scratch every single time. */
1984 static GTY(()) tree select_struct[2];
1986 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1987 Instead of generating compares and jumps, it is far simpler to
1988 generate a data structure describing the cases in order and call a
1989 library subroutine that locates the right case.
1990 This is particularly true because this is the only case where we
1991 might have to dispose of a temporary.
1992 The library subroutine returns a pointer to jump to or NULL if no
1993 branches are to be taken. */
1996 gfc_trans_character_select (gfc_code *code)
1998 tree init, end_label, tmp, type, case_num, label, fndecl;
1999 stmtblock_t block, body;
2004 VEC(constructor_elt,gc) *inits = NULL;
2006 tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
2008 /* The jump table types are stored in static variables to avoid
2009 constructing them from scratch every single time. */
2010 static tree ss_string1[2], ss_string1_len[2];
2011 static tree ss_string2[2], ss_string2_len[2];
2012 static tree ss_target[2];
2014 cp = code->block->ext.block.case_list;
2015 while (cp->left != NULL)
2018 /* Generate the body */
2019 gfc_start_block (&block);
2020 gfc_init_se (&expr1se, NULL);
2021 gfc_conv_expr_reference (&expr1se, code->expr1);
2023 gfc_add_block_to_block (&block, &expr1se.pre);
2025 end_label = gfc_build_label_decl (NULL_TREE);
2027 gfc_init_block (&body);
2029 /* Attempt to optimize length 1 selects. */
2030 if (integer_onep (expr1se.string_length))
2032 for (d = cp; d; d = d->right)
2037 gcc_assert (d->low->expr_type == EXPR_CONSTANT
2038 && d->low->ts.type == BT_CHARACTER);
2039 if (d->low->value.character.length > 1)
2041 for (i = 1; i < d->low->value.character.length; i++)
2042 if (d->low->value.character.string[i] != ' ')
2044 if (i != d->low->value.character.length)
2046 if (optimize && d->high && i == 1)
2048 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2049 && d->high->ts.type == BT_CHARACTER);
2050 if (d->high->value.character.length > 1
2051 && (d->low->value.character.string[0]
2052 == d->high->value.character.string[0])
2053 && d->high->value.character.string[1] != ' '
2054 && ((d->low->value.character.string[1] < ' ')
2055 == (d->high->value.character.string[1]
2065 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2066 && d->high->ts.type == BT_CHARACTER);
2067 if (d->high->value.character.length > 1)
2069 for (i = 1; i < d->high->value.character.length; i++)
2070 if (d->high->value.character.string[i] != ' ')
2072 if (i != d->high->value.character.length)
2079 tree ctype = gfc_get_char_type (code->expr1->ts.kind);
2081 for (c = code->block; c; c = c->block)
2083 for (cp = c->ext.block.case_list; cp; cp = cp->next)
2089 /* Assume it's the default case. */
2090 low = high = NULL_TREE;
2094 /* CASE ('ab') or CASE ('ab':'az') will never match
2095 any length 1 character. */
2096 if (cp->low->value.character.length > 1
2097 && cp->low->value.character.string[1] != ' ')
2100 if (cp->low->value.character.length > 0)
2101 r = cp->low->value.character.string[0];
2104 low = build_int_cst (ctype, r);
2106 /* If there's only a lower bound, set the high bound
2107 to the maximum value of the case expression. */
2109 high = TYPE_MAX_VALUE (ctype);
2115 || (cp->low->value.character.string[0]
2116 != cp->high->value.character.string[0]))
2118 if (cp->high->value.character.length > 0)
2119 r = cp->high->value.character.string[0];
2122 high = build_int_cst (ctype, r);
2125 /* Unbounded case. */
2127 low = TYPE_MIN_VALUE (ctype);
2130 /* Build a label. */
2131 label = gfc_build_label_decl (NULL_TREE);
2133 /* Add this case label.
2134 Add parameter 'label', make it match GCC backend. */
2135 tmp = build_case_label (low, high, label);
2136 gfc_add_expr_to_block (&body, tmp);
2139 /* Add the statements for this case. */
2140 tmp = gfc_trans_code (c->next);
2141 gfc_add_expr_to_block (&body, tmp);
2143 /* Break to the end of the construct. */
2144 tmp = build1_v (GOTO_EXPR, end_label);
2145 gfc_add_expr_to_block (&body, tmp);
2148 tmp = gfc_string_to_single_character (expr1se.string_length,
2150 code->expr1->ts.kind);
2151 case_num = gfc_create_var (ctype, "case_num");
2152 gfc_add_modify (&block, case_num, tmp);
2154 gfc_add_block_to_block (&block, &expr1se.post);
2156 tmp = gfc_finish_block (&body);
2157 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2158 gfc_add_expr_to_block (&block, tmp);
2160 tmp = build1_v (LABEL_EXPR, end_label);
2161 gfc_add_expr_to_block (&block, tmp);
2163 return gfc_finish_block (&block);
2167 if (code->expr1->ts.kind == 1)
2169 else if (code->expr1->ts.kind == 4)
2174 if (select_struct[k] == NULL)
2177 select_struct[k] = make_node (RECORD_TYPE);
2179 if (code->expr1->ts.kind == 1)
2180 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
2181 else if (code->expr1->ts.kind == 4)
2182 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
2187 #define ADD_FIELD(NAME, TYPE) \
2188 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2189 get_identifier (stringize(NAME)), \
2193 ADD_FIELD (string1, pchartype);
2194 ADD_FIELD (string1_len, gfc_charlen_type_node);
2196 ADD_FIELD (string2, pchartype);
2197 ADD_FIELD (string2_len, gfc_charlen_type_node);
2199 ADD_FIELD (target, integer_type_node);
2202 gfc_finish_type (select_struct[k]);
2206 for (d = cp; d; d = d->right)
2209 for (c = code->block; c; c = c->block)
2211 for (d = c->ext.block.case_list; d; d = d->next)
2213 label = gfc_build_label_decl (NULL_TREE);
2214 tmp = build_case_label ((d->low == NULL && d->high == NULL)
2216 : build_int_cst (integer_type_node, d->n),
2218 gfc_add_expr_to_block (&body, tmp);
2221 tmp = gfc_trans_code (c->next);
2222 gfc_add_expr_to_block (&body, tmp);
2224 tmp = build1_v (GOTO_EXPR, end_label);
2225 gfc_add_expr_to_block (&body, tmp);
2228 /* Generate the structure describing the branches */
2229 for (d = cp; d; d = d->right)
2231 VEC(constructor_elt,gc) *node = NULL;
2233 gfc_init_se (&se, NULL);
2237 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
2238 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
2242 gfc_conv_expr_reference (&se, d->low);
2244 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
2245 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
2248 if (d->high == NULL)
2250 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
2251 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
2255 gfc_init_se (&se, NULL);
2256 gfc_conv_expr_reference (&se, d->high);
2258 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
2259 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
2262 CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
2263 build_int_cst (integer_type_node, d->n));
2265 tmp = build_constructor (select_struct[k], node);
2266 CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
2269 type = build_array_type (select_struct[k],
2270 build_index_type (size_int (n-1)));
2272 init = build_constructor (type, inits);
2273 TREE_CONSTANT (init) = 1;
2274 TREE_STATIC (init) = 1;
2275 /* Create a static variable to hold the jump table. */
2276 tmp = gfc_create_var (type, "jumptable");
2277 TREE_CONSTANT (tmp) = 1;
2278 TREE_STATIC (tmp) = 1;
2279 TREE_READONLY (tmp) = 1;
2280 DECL_INITIAL (tmp) = init;
2283 /* Build the library call */
2284 init = gfc_build_addr_expr (pvoid_type_node, init);
2286 if (code->expr1->ts.kind == 1)
2287 fndecl = gfor_fndecl_select_string;
2288 else if (code->expr1->ts.kind == 4)
2289 fndecl = gfor_fndecl_select_string_char4;
2293 tmp = build_call_expr_loc (input_location,
2295 build_int_cst (gfc_charlen_type_node, n),
2296 expr1se.expr, expr1se.string_length);
2297 case_num = gfc_create_var (integer_type_node, "case_num");
2298 gfc_add_modify (&block, case_num, tmp);
2300 gfc_add_block_to_block (&block, &expr1se.post);
2302 tmp = gfc_finish_block (&body);
2303 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2304 gfc_add_expr_to_block (&block, tmp);
2306 tmp = build1_v (LABEL_EXPR, end_label);
2307 gfc_add_expr_to_block (&block, tmp);
2309 return gfc_finish_block (&block);
2313 /* Translate the three variants of the SELECT CASE construct.
2315 SELECT CASEs with INTEGER case expressions can be translated to an
2316 equivalent GENERIC switch statement, and for LOGICAL case
2317 expressions we build one or two if-else compares.
2319 SELECT CASEs with CHARACTER case expressions are a whole different
2320 story, because they don't exist in GENERIC. So we sort them and
2321 do a binary search at runtime.
2323 Fortran has no BREAK statement, and it does not allow jumps from
2324 one case block to another. That makes things a lot easier for
2328 gfc_trans_select (gfc_code * code)
2334 gcc_assert (code && code->expr1);
2335 gfc_init_block (&block);
2337 /* Build the exit label and hang it in. */
2338 exit_label = gfc_build_label_decl (NULL_TREE);
2339 code->exit_label = exit_label;
2341 /* Empty SELECT constructs are legal. */
2342 if (code->block == NULL)
2343 body = build_empty_stmt (input_location);
2345 /* Select the correct translation function. */
2347 switch (code->expr1->ts.type)
2350 body = gfc_trans_logical_select (code);
2354 body = gfc_trans_integer_select (code);
2358 body = gfc_trans_character_select (code);
2362 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2366 /* Build everything together. */
2367 gfc_add_expr_to_block (&block, body);
2368 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
2370 return gfc_finish_block (&block);
2374 /* Traversal function to substitute a replacement symtree if the symbol
2375 in the expression is the same as that passed. f == 2 signals that
2376 that variable itself is not to be checked - only the references.
2377 This group of functions is used when the variable expression in a
2378 FORALL assignment has internal references. For example:
2379 FORALL (i = 1:4) p(p(i)) = i
2380 The only recourse here is to store a copy of 'p' for the index
2383 static gfc_symtree *new_symtree;
2384 static gfc_symtree *old_symtree;
2387 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
2389 if (expr->expr_type != EXPR_VARIABLE)
2394 else if (expr->symtree->n.sym == sym)
2395 expr->symtree = new_symtree;
2401 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
2403 gfc_traverse_expr (e, sym, forall_replace, f);
2407 forall_restore (gfc_expr *expr,
2408 gfc_symbol *sym ATTRIBUTE_UNUSED,
2409 int *f ATTRIBUTE_UNUSED)
2411 if (expr->expr_type != EXPR_VARIABLE)
2414 if (expr->symtree == new_symtree)
2415 expr->symtree = old_symtree;
2421 forall_restore_symtree (gfc_expr *e)
2423 gfc_traverse_expr (e, NULL, forall_restore, 0);
2427 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2432 gfc_symbol *new_sym;
2433 gfc_symbol *old_sym;
2437 /* Build a copy of the lvalue. */
2438 old_symtree = c->expr1->symtree;
2439 old_sym = old_symtree->n.sym;
2440 e = gfc_lval_expr_from_sym (old_sym);
2441 if (old_sym->attr.dimension)
2443 gfc_init_se (&tse, NULL);
2444 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
2445 gfc_add_block_to_block (pre, &tse.pre);
2446 gfc_add_block_to_block (post, &tse.post);
2447 tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
2449 if (e->ts.type != BT_CHARACTER)
2451 /* Use the variable offset for the temporary. */
2452 tmp = gfc_conv_array_offset (old_sym->backend_decl);
2453 gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
2458 gfc_init_se (&tse, NULL);
2459 gfc_init_se (&rse, NULL);
2460 gfc_conv_expr (&rse, e);
2461 if (e->ts.type == BT_CHARACTER)
2463 tse.string_length = rse.string_length;
2464 tmp = gfc_get_character_type_len (gfc_default_character_kind,
2466 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
2468 gfc_add_block_to_block (pre, &tse.pre);
2469 gfc_add_block_to_block (post, &tse.post);
2473 tmp = gfc_typenode_for_spec (&e->ts);
2474 tse.expr = gfc_create_var (tmp, "temp");
2477 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
2478 e->expr_type == EXPR_VARIABLE, true);
2479 gfc_add_expr_to_block (pre, tmp);
2483 /* Create a new symbol to represent the lvalue. */
2484 new_sym = gfc_new_symbol (old_sym->name, NULL);
2485 new_sym->ts = old_sym->ts;
2486 new_sym->attr.referenced = 1;
2487 new_sym->attr.temporary = 1;
2488 new_sym->attr.dimension = old_sym->attr.dimension;
2489 new_sym->attr.flavor = old_sym->attr.flavor;
2491 /* Use the temporary as the backend_decl. */
2492 new_sym->backend_decl = tse.expr;
2494 /* Create a fake symtree for it. */
2496 new_symtree = gfc_new_symtree (&root, old_sym->name);
2497 new_symtree->n.sym = new_sym;
2498 gcc_assert (new_symtree == root);
2500 /* Go through the expression reference replacing the old_symtree
2502 forall_replace_symtree (c->expr1, old_sym, 2);
2504 /* Now we have made this temporary, we might as well use it for
2505 the right hand side. */
2506 forall_replace_symtree (c->expr2, old_sym, 1);
2510 /* Handles dependencies in forall assignments. */
2512 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2519 lsym = c->expr1->symtree->n.sym;
2520 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
2522 /* Now check for dependencies within the 'variable'
2523 expression itself. These are treated by making a complete
2524 copy of variable and changing all the references to it
2525 point to the copy instead. Note that the shallow copy of
2526 the variable will not suffice for derived types with
2527 pointer components. We therefore leave these to their
2529 if (lsym->ts.type == BT_DERIVED
2530 && lsym->ts.u.derived->attr.pointer_comp)
2534 if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
2536 forall_make_variable_temp (c, pre, post);
2540 /* Substrings with dependencies are treated in the same
2542 if (c->expr1->ts.type == BT_CHARACTER
2544 && c->expr2->expr_type == EXPR_VARIABLE
2545 && lsym == c->expr2->symtree->n.sym)
2547 for (lref = c->expr1->ref; lref; lref = lref->next)
2548 if (lref->type == REF_SUBSTRING)
2550 for (rref = c->expr2->ref; rref; rref = rref->next)
2551 if (rref->type == REF_SUBSTRING)
2555 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
2557 forall_make_variable_temp (c, pre, post);
2566 cleanup_forall_symtrees (gfc_code *c)
2568 forall_restore_symtree (c->expr1);
2569 forall_restore_symtree (c->expr2);
2570 free (new_symtree->n.sym);
2575 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
2576 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
2577 indicates whether we should generate code to test the FORALLs mask
2578 array. OUTER is the loop header to be used for initializing mask
2581 The generated loop format is:
2582 count = (end - start + step) / step
2595 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
2596 int mask_flag, stmtblock_t *outer)
2604 tree var, start, end, step;
2607 /* Initialize the mask index outside the FORALL nest. */
2608 if (mask_flag && forall_tmp->mask)
2609 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
2611 iter = forall_tmp->this_loop;
2612 nvar = forall_tmp->nvar;
2613 for (n = 0; n < nvar; n++)
2616 start = iter->start;
2620 exit_label = gfc_build_label_decl (NULL_TREE);
2621 TREE_USED (exit_label) = 1;
2623 /* The loop counter. */
2624 count = gfc_create_var (TREE_TYPE (var), "count");
2626 /* The body of the loop. */
2627 gfc_init_block (&block);
2629 /* The exit condition. */
2630 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
2631 count, build_int_cst (TREE_TYPE (count), 0));
2632 tmp = build1_v (GOTO_EXPR, exit_label);
2633 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2634 cond, tmp, build_empty_stmt (input_location));
2635 gfc_add_expr_to_block (&block, tmp);
2637 /* The main loop body. */
2638 gfc_add_expr_to_block (&block, body);
2640 /* Increment the loop variable. */
2641 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
2643 gfc_add_modify (&block, var, tmp);
2645 /* Advance to the next mask element. Only do this for the
2647 if (n == 0 && mask_flag && forall_tmp->mask)
2649 tree maskindex = forall_tmp->maskindex;
2650 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2651 maskindex, gfc_index_one_node);
2652 gfc_add_modify (&block, maskindex, tmp);
2655 /* Decrement the loop counter. */
2656 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
2657 build_int_cst (TREE_TYPE (var), 1));
2658 gfc_add_modify (&block, count, tmp);
2660 body = gfc_finish_block (&block);
2662 /* Loop var initialization. */
2663 gfc_init_block (&block);
2664 gfc_add_modify (&block, var, start);
2667 /* Initialize the loop counter. */
2668 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
2670 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
2672 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
2674 gfc_add_modify (&block, count, tmp);
2676 /* The loop expression. */
2677 tmp = build1_v (LOOP_EXPR, body);
2678 gfc_add_expr_to_block (&block, tmp);
2680 /* The exit label. */
2681 tmp = build1_v (LABEL_EXPR, exit_label);
2682 gfc_add_expr_to_block (&block, tmp);
2684 body = gfc_finish_block (&block);
2691 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
2692 is nonzero, the body is controlled by all masks in the forall nest.
2693 Otherwise, the innermost loop is not controlled by it's mask. This
2694 is used for initializing that mask. */
2697 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
2702 forall_info *forall_tmp;
2703 tree mask, maskindex;
2705 gfc_start_block (&header);
2707 forall_tmp = nested_forall_info;
2708 while (forall_tmp != NULL)
2710 /* Generate body with masks' control. */
2713 mask = forall_tmp->mask;
2714 maskindex = forall_tmp->maskindex;
2716 /* If a mask was specified make the assignment conditional. */
2719 tmp = gfc_build_array_ref (mask, maskindex, NULL);
2720 body = build3_v (COND_EXPR, tmp, body,
2721 build_empty_stmt (input_location));
2724 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
2725 forall_tmp = forall_tmp->prev_nest;
2729 gfc_add_expr_to_block (&header, body);
2730 return gfc_finish_block (&header);
2734 /* Allocate data for holding a temporary array. Returns either a local
2735 temporary array or a pointer variable. */
2738 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
2745 if (INTEGER_CST_P (size))
2746 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2747 size, gfc_index_one_node);
2751 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
2752 type = build_array_type (elem_type, type);
2753 if (gfc_can_put_var_on_stack (bytesize))
2755 gcc_assert (INTEGER_CST_P (size));
2756 tmpvar = gfc_create_var (type, "temp");
2761 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
2762 *pdata = convert (pvoid_type_node, tmpvar);
2764 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
2765 gfc_add_modify (pblock, tmpvar, tmp);
2771 /* Generate codes to copy the temporary to the actual lhs. */
2774 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
2775 tree count1, tree wheremask, bool invert)
2779 stmtblock_t block, body;
2785 lss = gfc_walk_expr (expr);
2787 if (lss == gfc_ss_terminator)
2789 gfc_start_block (&block);
2791 gfc_init_se (&lse, NULL);
2793 /* Translate the expression. */
2794 gfc_conv_expr (&lse, expr);
2796 /* Form the expression for the temporary. */
2797 tmp = gfc_build_array_ref (tmp1, count1, NULL);
2799 /* Use the scalar assignment as is. */
2800 gfc_add_block_to_block (&block, &lse.pre);
2801 gfc_add_modify (&block, lse.expr, tmp);
2802 gfc_add_block_to_block (&block, &lse.post);
2804 /* Increment the count1. */
2805 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2806 count1, gfc_index_one_node);
2807 gfc_add_modify (&block, count1, tmp);
2809 tmp = gfc_finish_block (&block);
2813 gfc_start_block (&block);
2815 gfc_init_loopinfo (&loop1);
2816 gfc_init_se (&rse, NULL);
2817 gfc_init_se (&lse, NULL);
2819 /* Associate the lss with the loop. */
2820 gfc_add_ss_to_loop (&loop1, lss);
2822 /* Calculate the bounds of the scalarization. */
2823 gfc_conv_ss_startstride (&loop1);
2824 /* Setup the scalarizing loops. */
2825 gfc_conv_loop_setup (&loop1, &expr->where);
2827 gfc_mark_ss_chain_used (lss, 1);
2829 /* Start the scalarized loop body. */
2830 gfc_start_scalarized_body (&loop1, &body);
2832 /* Setup the gfc_se structures. */
2833 gfc_copy_loopinfo_to_se (&lse, &loop1);
2836 /* Form the expression of the temporary. */
2837 if (lss != gfc_ss_terminator)
2838 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2839 /* Translate expr. */
2840 gfc_conv_expr (&lse, expr);
2842 /* Use the scalar assignment. */
2843 rse.string_length = lse.string_length;
2844 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
2846 /* Form the mask expression according to the mask tree list. */
2849 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2851 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2852 TREE_TYPE (wheremaskexpr),
2854 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2856 build_empty_stmt (input_location));
2859 gfc_add_expr_to_block (&body, tmp);
2861 /* Increment count1. */
2862 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2863 count1, gfc_index_one_node);
2864 gfc_add_modify (&body, count1, tmp);
2866 /* Increment count3. */
2869 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2870 gfc_array_index_type, count3,
2871 gfc_index_one_node);
2872 gfc_add_modify (&body, count3, tmp);
2875 /* Generate the copying loops. */
2876 gfc_trans_scalarizing_loops (&loop1, &body);
2877 gfc_add_block_to_block (&block, &loop1.pre);
2878 gfc_add_block_to_block (&block, &loop1.post);
2879 gfc_cleanup_loop (&loop1);
2881 tmp = gfc_finish_block (&block);
2887 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
2888 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
2889 and should not be freed. WHEREMASK is the conditional execution mask
2890 whose sense may be inverted by INVERT. */
2893 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
2894 tree count1, gfc_ss *lss, gfc_ss *rss,
2895 tree wheremask, bool invert)
2897 stmtblock_t block, body1;
2904 gfc_start_block (&block);
2906 gfc_init_se (&rse, NULL);
2907 gfc_init_se (&lse, NULL);
2909 if (lss == gfc_ss_terminator)
2911 gfc_init_block (&body1);
2912 gfc_conv_expr (&rse, expr2);
2913 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2917 /* Initialize the loop. */
2918 gfc_init_loopinfo (&loop);
2920 /* We may need LSS to determine the shape of the expression. */
2921 gfc_add_ss_to_loop (&loop, lss);
2922 gfc_add_ss_to_loop (&loop, rss);
2924 gfc_conv_ss_startstride (&loop);
2925 gfc_conv_loop_setup (&loop, &expr2->where);
2927 gfc_mark_ss_chain_used (rss, 1);
2928 /* Start the loop body. */
2929 gfc_start_scalarized_body (&loop, &body1);
2931 /* Translate the expression. */
2932 gfc_copy_loopinfo_to_se (&rse, &loop);
2934 gfc_conv_expr (&rse, expr2);
2936 /* Form the expression of the temporary. */
2937 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2940 /* Use the scalar assignment. */
2941 lse.string_length = rse.string_length;
2942 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
2943 expr2->expr_type == EXPR_VARIABLE, true);
2945 /* Form the mask expression according to the mask tree list. */
2948 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2950 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2951 TREE_TYPE (wheremaskexpr),
2953 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2955 build_empty_stmt (input_location));
2958 gfc_add_expr_to_block (&body1, tmp);
2960 if (lss == gfc_ss_terminator)
2962 gfc_add_block_to_block (&block, &body1);
2964 /* Increment count1. */
2965 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2966 count1, gfc_index_one_node);
2967 gfc_add_modify (&block, count1, tmp);
2971 /* Increment count1. */
2972 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2973 count1, gfc_index_one_node);
2974 gfc_add_modify (&body1, count1, tmp);
2976 /* Increment count3. */
2979 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2980 gfc_array_index_type,
2981 count3, gfc_index_one_node);
2982 gfc_add_modify (&body1, count3, tmp);
2985 /* Generate the copying loops. */
2986 gfc_trans_scalarizing_loops (&loop, &body1);
2988 gfc_add_block_to_block (&block, &loop.pre);
2989 gfc_add_block_to_block (&block, &loop.post);
2991 gfc_cleanup_loop (&loop);
2992 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2993 as tree nodes in SS may not be valid in different scope. */
2996 tmp = gfc_finish_block (&block);
3001 /* Calculate the size of temporary needed in the assignment inside forall.
3002 LSS and RSS are filled in this function. */
3005 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
3006 stmtblock_t * pblock,
3007 gfc_ss **lss, gfc_ss **rss)
3015 *lss = gfc_walk_expr (expr1);
3018 size = gfc_index_one_node;
3019 if (*lss != gfc_ss_terminator)
3021 gfc_init_loopinfo (&loop);
3023 /* Walk the RHS of the expression. */
3024 *rss = gfc_walk_expr (expr2);
3025 if (*rss == gfc_ss_terminator)
3026 /* The rhs is scalar. Add a ss for the expression. */
3027 *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
3029 /* Associate the SS with the loop. */
3030 gfc_add_ss_to_loop (&loop, *lss);
3031 /* We don't actually need to add the rhs at this point, but it might
3032 make guessing the loop bounds a bit easier. */
3033 gfc_add_ss_to_loop (&loop, *rss);
3035 /* We only want the shape of the expression, not rest of the junk
3036 generated by the scalarizer. */
3037 loop.array_parameter = 1;
3039 /* Calculate the bounds of the scalarization. */
3040 save_flag = gfc_option.rtcheck;
3041 gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
3042 gfc_conv_ss_startstride (&loop);
3043 gfc_option.rtcheck = save_flag;
3044 gfc_conv_loop_setup (&loop, &expr2->where);
3046 /* Figure out how many elements we need. */
3047 for (i = 0; i < loop.dimen; i++)
3049 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3050 gfc_array_index_type,
3051 gfc_index_one_node, loop.from[i]);
3052 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3053 gfc_array_index_type, tmp, loop.to[i]);
3054 size = fold_build2_loc (input_location, MULT_EXPR,
3055 gfc_array_index_type, size, tmp);
3057 gfc_add_block_to_block (pblock, &loop.pre);
3058 size = gfc_evaluate_now (size, pblock);
3059 gfc_add_block_to_block (pblock, &loop.post);
3061 /* TODO: write a function that cleans up a loopinfo without freeing
3062 the SS chains. Currently a NOP. */
3069 /* Calculate the overall iterator number of the nested forall construct.
3070 This routine actually calculates the number of times the body of the
3071 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3072 that by the expression INNER_SIZE. The BLOCK argument specifies the
3073 block in which to calculate the result, and the optional INNER_SIZE_BODY
3074 argument contains any statements that need to executed (inside the loop)
3075 to initialize or calculate INNER_SIZE. */
3078 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
3079 stmtblock_t *inner_size_body, stmtblock_t *block)
3081 forall_info *forall_tmp = nested_forall_info;
3085 /* We can eliminate the innermost unconditional loops with constant
3087 if (INTEGER_CST_P (inner_size))
3090 && !forall_tmp->mask
3091 && INTEGER_CST_P (forall_tmp->size))
3093 inner_size = fold_build2_loc (input_location, MULT_EXPR,
3094 gfc_array_index_type,
3095 inner_size, forall_tmp->size);
3096 forall_tmp = forall_tmp->prev_nest;
3099 /* If there are no loops left, we have our constant result. */
3104 /* Otherwise, create a temporary variable to compute the result. */
3105 number = gfc_create_var (gfc_array_index_type, "num");
3106 gfc_add_modify (block, number, gfc_index_zero_node);
3108 gfc_start_block (&body);
3109 if (inner_size_body)
3110 gfc_add_block_to_block (&body, inner_size_body);
3112 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3113 gfc_array_index_type, number, inner_size);
3116 gfc_add_modify (&body, number, tmp);
3117 tmp = gfc_finish_block (&body);
3119 /* Generate loops. */
3120 if (forall_tmp != NULL)
3121 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
3123 gfc_add_expr_to_block (block, tmp);
3129 /* Allocate temporary for forall construct. SIZE is the size of temporary
3130 needed. PTEMP1 is returned for space free. */
3133 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
3140 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
3141 if (!integer_onep (unit))
3142 bytesize = fold_build2_loc (input_location, MULT_EXPR,
3143 gfc_array_index_type, size, unit);
3148 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
3151 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3156 /* Allocate temporary for forall construct according to the information in
3157 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3158 assignment inside forall. PTEMP1 is returned for space free. */
3161 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
3162 tree inner_size, stmtblock_t * inner_size_body,
3163 stmtblock_t * block, tree * ptemp1)
3167 /* Calculate the total size of temporary needed in forall construct. */
3168 size = compute_overall_iter_number (nested_forall_info, inner_size,
3169 inner_size_body, block);
3171 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
3175 /* Handle assignments inside forall which need temporary.
3177 forall (i=start:end:stride; maskexpr)
3180 (where e,f<i> are arbitrary expressions possibly involving i
3181 and there is a dependency between e<i> and f<i>)
3183 masktmp(:) = maskexpr(:)
3188 for (i = start; i <= end; i += stride)
3192 for (i = start; i <= end; i += stride)
3194 if (masktmp[maskindex++])
3195 tmp[count1++] = f<i>
3199 for (i = start; i <= end; i += stride)
3201 if (masktmp[maskindex++])
3202 e<i> = tmp[count1++]
3207 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3208 tree wheremask, bool invert,
3209 forall_info * nested_forall_info,
3210 stmtblock_t * block)
3218 stmtblock_t inner_size_body;
3220 /* Create vars. count1 is the current iterator number of the nested
3222 count1 = gfc_create_var (gfc_array_index_type, "count1");
3224 /* Count is the wheremask index. */
3227 count = gfc_create_var (gfc_array_index_type, "count");
3228 gfc_add_modify (block, count, gfc_index_zero_node);
3233 /* Initialize count1. */
3234 gfc_add_modify (block, count1, gfc_index_zero_node);
3236 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3237 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3238 gfc_init_block (&inner_size_body);
3239 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
3242 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3243 if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
3245 if (!expr1->ts.u.cl->backend_decl)
3248 gfc_init_se (&tse, NULL);
3249 gfc_conv_expr (&tse, expr1->ts.u.cl->length);
3250 expr1->ts.u.cl->backend_decl = tse.expr;
3252 type = gfc_get_character_type_len (gfc_default_character_kind,
3253 expr1->ts.u.cl->backend_decl);
3256 type = gfc_typenode_for_spec (&expr1->ts);
3258 /* Allocate temporary for nested forall construct according to the
3259 information in nested_forall_info and inner_size. */
3260 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
3261 &inner_size_body, block, &ptemp1);
3263 /* Generate codes to copy rhs to the temporary . */
3264 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
3267 /* Generate body and loops according to the information in
3268 nested_forall_info. */
3269 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3270 gfc_add_expr_to_block (block, tmp);
3273 gfc_add_modify (block, count1, gfc_index_zero_node);
3277 gfc_add_modify (block, count, gfc_index_zero_node);
3279 /* Generate codes to copy the temporary to lhs. */
3280 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
3283 /* Generate body and loops according to the information in
3284 nested_forall_info. */
3285 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3286 gfc_add_expr_to_block (block, tmp);
3290 /* Free the temporary. */
3291 tmp = gfc_call_free (ptemp1);
3292 gfc_add_expr_to_block (block, tmp);
3297 /* Translate pointer assignment inside FORALL which need temporary. */
3300 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3301 forall_info * nested_forall_info,
3302 stmtblock_t * block)
3316 tree tmp, tmp1, ptemp1;
3318 count = gfc_create_var (gfc_array_index_type, "count");
3319 gfc_add_modify (block, count, gfc_index_zero_node);
3321 inner_size = gfc_index_one_node;
3322 lss = gfc_walk_expr (expr1);
3323 rss = gfc_walk_expr (expr2);
3324 if (lss == gfc_ss_terminator)
3326 type = gfc_typenode_for_spec (&expr1->ts);
3327 type = build_pointer_type (type);
3329 /* Allocate temporary for nested forall construct according to the
3330 information in nested_forall_info and inner_size. */
3331 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
3332 inner_size, NULL, block, &ptemp1);
3333 gfc_start_block (&body);
3334 gfc_init_se (&lse, NULL);
3335 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3336 gfc_init_se (&rse, NULL);
3337 rse.want_pointer = 1;
3338 gfc_conv_expr (&rse, expr2);
3339 gfc_add_block_to_block (&body, &rse.pre);
3340 gfc_add_modify (&body, lse.expr,
3341 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3342 gfc_add_block_to_block (&body, &rse.post);
3344 /* Increment count. */
3345 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3346 count, gfc_index_one_node);
3347 gfc_add_modify (&body, count, tmp);
3349 tmp = gfc_finish_block (&body);
3351 /* Generate body and loops according to the information in
3352 nested_forall_info. */
3353 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3354 gfc_add_expr_to_block (block, tmp);
3357 gfc_add_modify (block, count, gfc_index_zero_node);
3359 gfc_start_block (&body);
3360 gfc_init_se (&lse, NULL);
3361 gfc_init_se (&rse, NULL);
3362 rse.expr = gfc_build_array_ref (tmp1, count, NULL);
3363 lse.want_pointer = 1;
3364 gfc_conv_expr (&lse, expr1);
3365 gfc_add_block_to_block (&body, &lse.pre);
3366 gfc_add_modify (&body, lse.expr, rse.expr);
3367 gfc_add_block_to_block (&body, &lse.post);
3368 /* Increment count. */
3369 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3370 count, gfc_index_one_node);
3371 gfc_add_modify (&body, count, tmp);
3372 tmp = gfc_finish_block (&body);
3374 /* Generate body and loops according to the information in
3375 nested_forall_info. */
3376 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3377 gfc_add_expr_to_block (block, tmp);
3381 gfc_init_loopinfo (&loop);
3383 /* Associate the SS with the loop. */
3384 gfc_add_ss_to_loop (&loop, rss);
3386 /* Setup the scalarizing loops and bounds. */
3387 gfc_conv_ss_startstride (&loop);
3389 gfc_conv_loop_setup (&loop, &expr2->where);
3391 info = &rss->data.info;
3392 desc = info->descriptor;
3394 /* Make a new descriptor. */
3395 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3396 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
3397 loop.from, loop.to, 1,
3398 GFC_ARRAY_UNKNOWN, true);
3400 /* Allocate temporary for nested forall construct. */
3401 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
3402 inner_size, NULL, block, &ptemp1);
3403 gfc_start_block (&body);
3404 gfc_init_se (&lse, NULL);
3405 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3406 lse.direct_byref = 1;
3407 rss = gfc_walk_expr (expr2);
3408 gfc_conv_expr_descriptor (&lse, expr2, rss);
3410 gfc_add_block_to_block (&body, &lse.pre);
3411 gfc_add_block_to_block (&body, &lse.post);
3413 /* Increment count. */
3414 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3415 count, gfc_index_one_node);
3416 gfc_add_modify (&body, count, tmp);
3418 tmp = gfc_finish_block (&body);
3420 /* Generate body and loops according to the information in
3421 nested_forall_info. */
3422 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3423 gfc_add_expr_to_block (block, tmp);
3426 gfc_add_modify (block, count, gfc_index_zero_node);
3428 parm = gfc_build_array_ref (tmp1, count, NULL);
3429 lss = gfc_walk_expr (expr1);
3430 gfc_init_se (&lse, NULL);
3431 gfc_conv_expr_descriptor (&lse, expr1, lss);
3432 gfc_add_modify (&lse.pre, lse.expr, parm);
3433 gfc_start_block (&body);
3434 gfc_add_block_to_block (&body, &lse.pre);
3435 gfc_add_block_to_block (&body, &lse.post);
3437 /* Increment count. */
3438 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3439 count, gfc_index_one_node);
3440 gfc_add_modify (&body, count, tmp);
3442 tmp = gfc_finish_block (&body);
3444 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3445 gfc_add_expr_to_block (block, tmp);
3447 /* Free the temporary. */
3450 tmp = gfc_call_free (ptemp1);
3451 gfc_add_expr_to_block (block, tmp);
3456 /* FORALL and WHERE statements are really nasty, especially when you nest
3457 them. All the rhs of a forall assignment must be evaluated before the
3458 actual assignments are performed. Presumably this also applies to all the
3459 assignments in an inner where statement. */
3461 /* Generate code for a FORALL statement. Any temporaries are allocated as a
3462 linear array, relying on the fact that we process in the same order in all
3465 forall (i=start:end:stride; maskexpr)
3469 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
3471 count = ((end + 1 - start) / stride)
3472 masktmp(:) = maskexpr(:)
3475 for (i = start; i <= end; i += stride)
3477 if (masktmp[maskindex++])
3481 for (i = start; i <= end; i += stride)
3483 if (masktmp[maskindex++])
3487 Note that this code only works when there are no dependencies.
3488 Forall loop with array assignments and data dependencies are a real pain,
3489 because the size of the temporary cannot always be determined before the
3490 loop is executed. This problem is compounded by the presence of nested
3495 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
3512 tree cycle_label = NULL_TREE;
3516 gfc_forall_iterator *fa;
3519 gfc_saved_var *saved_vars;
3520 iter_info *this_forall;
3524 /* Do nothing if the mask is false. */
3526 && code->expr1->expr_type == EXPR_CONSTANT
3527 && !code->expr1->value.logical)
3528 return build_empty_stmt (input_location);
3531 /* Count the FORALL index number. */
3532 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3536 /* Allocate the space for var, start, end, step, varexpr. */
3537 var = XCNEWVEC (tree, nvar);
3538 start = XCNEWVEC (tree, nvar);
3539 end = XCNEWVEC (tree, nvar);
3540 step = XCNEWVEC (tree, nvar);
3541 varexpr = XCNEWVEC (gfc_expr *, nvar);
3542 saved_vars = XCNEWVEC (gfc_saved_var, nvar);
3544 /* Allocate the space for info. */
3545 info = XCNEW (forall_info);
3547 gfc_start_block (&pre);
3548 gfc_init_block (&post);
3549 gfc_init_block (&block);
3552 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3554 gfc_symbol *sym = fa->var->symtree->n.sym;
3556 /* Allocate space for this_forall. */
3557 this_forall = XCNEW (iter_info);
3559 /* Create a temporary variable for the FORALL index. */
3560 tmp = gfc_typenode_for_spec (&sym->ts);
3561 var[n] = gfc_create_var (tmp, sym->name);
3562 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
3564 /* Record it in this_forall. */
3565 this_forall->var = var[n];
3567 /* Replace the index symbol's backend_decl with the temporary decl. */
3568 sym->backend_decl = var[n];
3570 /* Work out the start, end and stride for the loop. */
3571 gfc_init_se (&se, NULL);
3572 gfc_conv_expr_val (&se, fa->start);
3573 /* Record it in this_forall. */
3574 this_forall->start = se.expr;
3575 gfc_add_block_to_block (&block, &se.pre);
3578 gfc_init_se (&se, NULL);
3579 gfc_conv_expr_val (&se, fa->end);
3580 /* Record it in this_forall. */
3581 this_forall->end = se.expr;
3582 gfc_make_safe_expr (&se);
3583 gfc_add_block_to_block (&block, &se.pre);
3586 gfc_init_se (&se, NULL);
3587 gfc_conv_expr_val (&se, fa->stride);
3588 /* Record it in this_forall. */
3589 this_forall->step = se.expr;
3590 gfc_make_safe_expr (&se);
3591 gfc_add_block_to_block (&block, &se.pre);
3594 /* Set the NEXT field of this_forall to NULL. */
3595 this_forall->next = NULL;
3596 /* Link this_forall to the info construct. */
3597 if (info->this_loop)
3599 iter_info *iter_tmp = info->this_loop;
3600 while (iter_tmp->next != NULL)
3601 iter_tmp = iter_tmp->next;
3602 iter_tmp->next = this_forall;
3605 info->this_loop = this_forall;
3611 /* Calculate the size needed for the current forall level. */
3612 size = gfc_index_one_node;
3613 for (n = 0; n < nvar; n++)
3615 /* size = (end + step - start) / step. */
3616 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
3618 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
3620 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
3622 tmp = convert (gfc_array_index_type, tmp);
3624 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3628 /* Record the nvar and size of current forall level. */
3634 /* If the mask is .true., consider the FORALL unconditional. */
3635 if (code->expr1->expr_type == EXPR_CONSTANT
3636 && code->expr1->value.logical)
3644 /* First we need to allocate the mask. */
3647 /* As the mask array can be very big, prefer compact boolean types. */
3648 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3649 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
3650 size, NULL, &block, &pmask);
3651 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
3653 /* Record them in the info structure. */
3654 info->maskindex = maskindex;
3659 /* No mask was specified. */
3660 maskindex = NULL_TREE;
3661 mask = pmask = NULL_TREE;
3664 /* Link the current forall level to nested_forall_info. */
3665 info->prev_nest = nested_forall_info;
3666 nested_forall_info = info;
3668 /* Copy the mask into a temporary variable if required.
3669 For now we assume a mask temporary is needed. */
3672 /* As the mask array can be very big, prefer compact boolean types. */
3673 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3675 gfc_add_modify (&block, maskindex, gfc_index_zero_node);
3677 /* Start of mask assignment loop body. */
3678 gfc_start_block (&body);
3680 /* Evaluate the mask expression. */
3681 gfc_init_se (&se, NULL);
3682 gfc_conv_expr_val (&se, code->expr1);
3683 gfc_add_block_to_block (&body, &se.pre);
3685 /* Store the mask. */
3686 se.expr = convert (mask_type, se.expr);
3688 tmp = gfc_build_array_ref (mask, maskindex, NULL);
3689 gfc_add_modify (&body, tmp, se.expr);
3691 /* Advance to the next mask element. */
3692 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3693 maskindex, gfc_index_one_node);
3694 gfc_add_modify (&body, maskindex, tmp);
3696 /* Generate the loops. */
3697 tmp = gfc_finish_block (&body);
3698 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
3699 gfc_add_expr_to_block (&block, tmp);
3702 if (code->op == EXEC_DO_CONCURRENT)
3704 gfc_init_block (&body);
3705 cycle_label = gfc_build_label_decl (NULL_TREE);
3706 code->cycle_label = cycle_label;
3707 tmp = gfc_trans_code (code->block->next);
3708 gfc_add_expr_to_block (&body, tmp);
3710 if (TREE_USED (cycle_label))
3712 tmp = build1_v (LABEL_EXPR, cycle_label);
3713 gfc_add_expr_to_block (&body, tmp);
3716 tmp = gfc_finish_block (&body);
3717 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3718 gfc_add_expr_to_block (&block, tmp);
3722 c = code->block->next;
3724 /* TODO: loop merging in FORALL statements. */
3725 /* Now that we've got a copy of the mask, generate the assignment loops. */
3731 /* A scalar or array assignment. DO the simple check for
3732 lhs to rhs dependencies. These make a temporary for the
3733 rhs and form a second forall block to copy to variable. */
3734 need_temp = check_forall_dependencies(c, &pre, &post);
3736 /* Temporaries due to array assignment data dependencies introduce
3737 no end of problems. */
3739 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
3740 nested_forall_info, &block);
3743 /* Use the normal assignment copying routines. */
3744 assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
3746 /* Generate body and loops. */
3747 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3749 gfc_add_expr_to_block (&block, tmp);
3752 /* Cleanup any temporary symtrees that have been made to deal
3753 with dependencies. */
3755 cleanup_forall_symtrees (c);
3760 /* Translate WHERE or WHERE construct nested in FORALL. */
3761 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
3764 /* Pointer assignment inside FORALL. */
3765 case EXEC_POINTER_ASSIGN:
3766 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
3768 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
3769 nested_forall_info, &block);
3772 /* Use the normal assignment copying routines. */
3773 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
3775 /* Generate body and loops. */
3776 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3778 gfc_add_expr_to_block (&block, tmp);
3783 tmp = gfc_trans_forall_1 (c, nested_forall_info);
3784 gfc_add_expr_to_block (&block, tmp);
3787 /* Explicit subroutine calls are prevented by the frontend but interface
3788 assignments can legitimately produce them. */
3789 case EXEC_ASSIGN_CALL:
3790 assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
3791 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
3792 gfc_add_expr_to_block (&block, tmp);
3803 /* Restore the original index variables. */
3804 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
3805 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
3807 /* Free the space for var, start, end, step, varexpr. */
3815 for (this_forall = info->this_loop; this_forall;)
3817 iter_info *next = this_forall->next;
3822 /* Free the space for this forall_info. */
3827 /* Free the temporary for the mask. */
3828 tmp = gfc_call_free (pmask);
3829 gfc_add_expr_to_block (&block, tmp);
3832 pushdecl (maskindex);
3834 gfc_add_block_to_block (&pre, &block);
3835 gfc_add_block_to_block (&pre, &post);
3837 return gfc_finish_block (&pre);
3841 /* Translate the FORALL statement or construct. */
3843 tree gfc_trans_forall (gfc_code * code)
3845 return gfc_trans_forall_1 (code, NULL);
3849 /* Translate the DO CONCURRENT construct. */
3851 tree gfc_trans_do_concurrent (gfc_code * code)
3853 return gfc_trans_forall_1 (code, NULL);
3857 /* Evaluate the WHERE mask expression, copy its value to a temporary.
3858 If the WHERE construct is nested in FORALL, compute the overall temporary
3859 needed by the WHERE mask expression multiplied by the iterator number of
3861 ME is the WHERE mask expression.
3862 MASK is the current execution mask upon input, whose sense may or may
3863 not be inverted as specified by the INVERT argument.
3864 CMASK is the updated execution mask on output, or NULL if not required.
3865 PMASK is the pending execution mask on output, or NULL if not required.
3866 BLOCK is the block in which to place the condition evaluation loops. */
3869 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
3870 tree mask, bool invert, tree cmask, tree pmask,
3871 tree mask_type, stmtblock_t * block)
3876 stmtblock_t body, body1;
3877 tree count, cond, mtmp;
3880 gfc_init_loopinfo (&loop);
3882 lss = gfc_walk_expr (me);
3883 rss = gfc_walk_expr (me);
3885 /* Variable to index the temporary. */
3886 count = gfc_create_var (gfc_array_index_type, "count");
3887 /* Initialize count. */
3888 gfc_add_modify (block, count, gfc_index_zero_node);
3890 gfc_start_block (&body);
3892 gfc_init_se (&rse, NULL);
3893 gfc_init_se (&lse, NULL);
3895 if (lss == gfc_ss_terminator)
3897 gfc_init_block (&body1);
3901 /* Initialize the loop. */
3902 gfc_init_loopinfo (&loop);
3904 /* We may need LSS to determine the shape of the expression. */
3905 gfc_add_ss_to_loop (&loop, lss);
3906 gfc_add_ss_to_loop (&loop, rss);
3908 gfc_conv_ss_startstride (&loop);
3909 gfc_conv_loop_setup (&loop, &me->where);
3911 gfc_mark_ss_chain_used (rss, 1);
3912 /* Start the loop body. */
3913 gfc_start_scalarized_body (&loop, &body1);
3915 /* Translate the expression. */
3916 gfc_copy_loopinfo_to_se (&rse, &loop);
3918 gfc_conv_expr (&rse, me);
3921 /* Variable to evaluate mask condition. */
3922 cond = gfc_create_var (mask_type, "cond");
3923 if (mask && (cmask || pmask))
3924 mtmp = gfc_create_var (mask_type, "mask");
3925 else mtmp = NULL_TREE;
3927 gfc_add_block_to_block (&body1, &lse.pre);
3928 gfc_add_block_to_block (&body1, &rse.pre);
3930 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
3932 if (mask && (cmask || pmask))
3934 tmp = gfc_build_array_ref (mask, count, NULL);
3936 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
3937 gfc_add_modify (&body1, mtmp, tmp);
3942 tmp1 = gfc_build_array_ref (cmask, count, NULL);
3945 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
3947 gfc_add_modify (&body1, tmp1, tmp);
3952 tmp1 = gfc_build_array_ref (pmask, count, NULL);
3953 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
3955 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
3957 gfc_add_modify (&body1, tmp1, tmp);
3960 gfc_add_block_to_block (&body1, &lse.post);
3961 gfc_add_block_to_block (&body1, &rse.post);
3963 if (lss == gfc_ss_terminator)
3965 gfc_add_block_to_block (&body, &body1);
3969 /* Increment count. */
3970 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3971 count, gfc_index_one_node);
3972 gfc_add_modify (&body1, count, tmp1);
3974 /* Generate the copying loops. */
3975 gfc_trans_scalarizing_loops (&loop, &body1);
3977 gfc_add_block_to_block (&body, &loop.pre);
3978 gfc_add_block_to_block (&body, &loop.post);
3980 gfc_cleanup_loop (&loop);
3981 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3982 as tree nodes in SS may not be valid in different scope. */
3985 tmp1 = gfc_finish_block (&body);
3986 /* If the WHERE construct is inside FORALL, fill the full temporary. */
3987 if (nested_forall_info != NULL)
3988 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
3990 gfc_add_expr_to_block (block, tmp1);
3994 /* Translate an assignment statement in a WHERE statement or construct
3995 statement. The MASK expression is used to control which elements
3996 of EXPR1 shall be assigned. The sense of MASK is specified by
4000 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
4001 tree mask, bool invert,
4002 tree count1, tree count2,
4008 gfc_ss *lss_section;
4015 tree index, maskexpr;
4017 /* A defined assignment. */
4018 if (cnext && cnext->resolved_sym)
4019 return gfc_trans_call (cnext, true, mask, count1, invert);
4022 /* TODO: handle this special case.
4023 Special case a single function returning an array. */
4024 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4026 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4032 /* Assignment of the form lhs = rhs. */
4033 gfc_start_block (&block);
4035 gfc_init_se (&lse, NULL);
4036 gfc_init_se (&rse, NULL);
4039 lss = gfc_walk_expr (expr1);
4042 /* In each where-assign-stmt, the mask-expr and the variable being
4043 defined shall be arrays of the same shape. */
4044 gcc_assert (lss != gfc_ss_terminator);
4046 /* The assignment needs scalarization. */
4049 /* Find a non-scalar SS from the lhs. */
4050 while (lss_section != gfc_ss_terminator
4051 && lss_section->type != GFC_SS_SECTION)
4052 lss_section = lss_section->next;
4054 gcc_assert (lss_section != gfc_ss_terminator);
4056 /* Initialize the scalarizer. */
4057 gfc_init_loopinfo (&loop);
4060 rss = gfc_walk_expr (expr2);
4061 if (rss == gfc_ss_terminator)
4063 /* The rhs is scalar. Add a ss for the expression. */
4064 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4068 /* Associate the SS with the loop. */
4069 gfc_add_ss_to_loop (&loop, lss);
4070 gfc_add_ss_to_loop (&loop, rss);
4072 /* Calculate the bounds of the scalarization. */
4073 gfc_conv_ss_startstride (&loop);
4075 /* Resolve any data dependencies in the statement. */
4076 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
4078 /* Setup the scalarizing loops. */
4079 gfc_conv_loop_setup (&loop, &expr2->where);
4081 /* Setup the gfc_se structures. */
4082 gfc_copy_loopinfo_to_se (&lse, &loop);
4083 gfc_copy_loopinfo_to_se (&rse, &loop);
4086 gfc_mark_ss_chain_used (rss, 1);
4087 if (loop.temp_ss == NULL)
4090 gfc_mark_ss_chain_used (lss, 1);
4094 lse.ss = loop.temp_ss;
4095 gfc_mark_ss_chain_used (lss, 3);
4096 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4099 /* Start the scalarized loop body. */
4100 gfc_start_scalarized_body (&loop, &body);
4102 /* Translate the expression. */
4103 gfc_conv_expr (&rse, expr2);
4104 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
4105 gfc_conv_tmp_array_ref (&lse);
4107 gfc_conv_expr (&lse, expr1);
4109 /* Form the mask expression according to the mask. */
4111 maskexpr = gfc_build_array_ref (mask, index, NULL);
4113 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4114 TREE_TYPE (maskexpr), maskexpr);
4116 /* Use the scalar assignment as is. */
4117 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4118 loop.temp_ss != NULL, false, true);
4120 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
4122 gfc_add_expr_to_block (&body, tmp);
4124 if (lss == gfc_ss_terminator)
4126 /* Increment count1. */
4127 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4128 count1, gfc_index_one_node);
4129 gfc_add_modify (&body, count1, tmp);
4131 /* Use the scalar assignment as is. */
4132 gfc_add_block_to_block (&block, &body);
4136 gcc_assert (lse.ss == gfc_ss_terminator
4137 && rse.ss == gfc_ss_terminator);
4139 if (loop.temp_ss != NULL)
4141 /* Increment count1 before finish the main body of a scalarized
4143 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4144 gfc_array_index_type, count1, gfc_index_one_node);
4145 gfc_add_modify (&body, count1, tmp);
4146 gfc_trans_scalarized_loop_boundary (&loop, &body);
4148 /* We need to copy the temporary to the actual lhs. */
4149 gfc_init_se (&lse, NULL);
4150 gfc_init_se (&rse, NULL);
4151 gfc_copy_loopinfo_to_se (&lse, &loop);
4152 gfc_copy_loopinfo_to_se (&rse, &loop);
4154 rse.ss = loop.temp_ss;
4157 gfc_conv_tmp_array_ref (&rse);
4158 gfc_conv_expr (&lse, expr1);
4160 gcc_assert (lse.ss == gfc_ss_terminator
4161 && rse.ss == gfc_ss_terminator);
4163 /* Form the mask expression according to the mask tree list. */
4165 maskexpr = gfc_build_array_ref (mask, index, NULL);
4167 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4168 TREE_TYPE (maskexpr), maskexpr);
4170 /* Use the scalar assignment as is. */
4171 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
4173 tmp = build3_v (COND_EXPR, maskexpr, tmp,
4174 build_empty_stmt (input_location));
4175 gfc_add_expr_to_block (&body, tmp);
4177 /* Increment count2. */
4178 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4179 gfc_array_index_type, count2,
4180 gfc_index_one_node);
4181 gfc_add_modify (&body, count2, tmp);
4185 /* Increment count1. */
4186 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4187 gfc_array_index_type, count1,
4188 gfc_index_one_node);
4189 gfc_add_modify (&body, count1, tmp);
4192 /* Generate the copying loops. */
4193 gfc_trans_scalarizing_loops (&loop, &body);
4195 /* Wrap the whole thing up. */
4196 gfc_add_block_to_block (&block, &loop.pre);
4197 gfc_add_block_to_block (&block, &loop.post);
4198 gfc_cleanup_loop (&loop);
4201 return gfc_finish_block (&block);
4205 /* Translate the WHERE construct or statement.
4206 This function can be called iteratively to translate the nested WHERE
4207 construct or statement.
4208 MASK is the control mask. */
4211 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
4212 forall_info * nested_forall_info, stmtblock_t * block)
4214 stmtblock_t inner_size_body;
4215 tree inner_size, size;
4224 tree count1, count2;
4228 tree pcmask = NULL_TREE;
4229 tree ppmask = NULL_TREE;
4230 tree cmask = NULL_TREE;
4231 tree pmask = NULL_TREE;
4232 gfc_actual_arglist *arg;
4234 /* the WHERE statement or the WHERE construct statement. */
4235 cblock = code->block;
4237 /* As the mask array can be very big, prefer compact boolean types. */
4238 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
4240 /* Determine which temporary masks are needed. */
4243 /* One clause: No ELSEWHEREs. */
4244 need_cmask = (cblock->next != 0);
4247 else if (cblock->block->block)
4249 /* Three or more clauses: Conditional ELSEWHEREs. */
4253 else if (cblock->next)
4255 /* Two clauses, the first non-empty. */
4257 need_pmask = (mask != NULL_TREE
4258 && cblock->block->next != 0);
4260 else if (!cblock->block->next)
4262 /* Two clauses, both empty. */
4266 /* Two clauses, the first empty, the second non-empty. */
4269 need_cmask = (cblock->block->expr1 != 0);
4278 if (need_cmask || need_pmask)
4280 /* Calculate the size of temporary needed by the mask-expr. */
4281 gfc_init_block (&inner_size_body);
4282 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
4283 &inner_size_body, &lss, &rss);
4285 gfc_free_ss_chain (lss);
4286 gfc_free_ss_chain (rss);
4288 /* Calculate the total size of temporary needed. */
4289 size = compute_overall_iter_number (nested_forall_info, inner_size,
4290 &inner_size_body, block);
4292 /* Check whether the size is negative. */
4293 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
4294 gfc_index_zero_node);
4295 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4296 cond, gfc_index_zero_node, size);
4297 size = gfc_evaluate_now (size, block);
4299 /* Allocate temporary for WHERE mask if needed. */
4301 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4304 /* Allocate temporary for !mask if needed. */
4306 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4312 /* Each time around this loop, the where clause is conditional
4313 on the value of mask and invert, which are updated at the
4314 bottom of the loop. */
4316 /* Has mask-expr. */
4319 /* Ensure that the WHERE mask will be evaluated exactly once.
4320 If there are no statements in this WHERE/ELSEWHERE clause,
4321 then we don't need to update the control mask (cmask).
4322 If this is the last clause of the WHERE construct, then
4323 we don't need to update the pending control mask (pmask). */
4325 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4327 cblock->next ? cmask : NULL_TREE,
4328 cblock->block ? pmask : NULL_TREE,
4331 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4333 (cblock->next || cblock->block)
4334 ? cmask : NULL_TREE,
4335 NULL_TREE, mask_type, block);
4339 /* It's a final elsewhere-stmt. No mask-expr is present. */
4343 /* The body of this where clause are controlled by cmask with
4344 sense specified by invert. */
4346 /* Get the assignment statement of a WHERE statement, or the first
4347 statement in where-body-construct of a WHERE construct. */
4348 cnext = cblock->next;
4353 /* WHERE assignment statement. */
4354 case EXEC_ASSIGN_CALL:
4356 arg = cnext->ext.actual;
4357 expr1 = expr2 = NULL;
4358 for (; arg; arg = arg->next)
4370 expr1 = cnext->expr1;
4371 expr2 = cnext->expr2;
4373 if (nested_forall_info != NULL)
4375 need_temp = gfc_check_dependency (expr1, expr2, 0);
4376 if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
4377 gfc_trans_assign_need_temp (expr1, expr2,
4379 nested_forall_info, block);
4382 /* Variables to control maskexpr. */
4383 count1 = gfc_create_var (gfc_array_index_type, "count1");
4384 count2 = gfc_create_var (gfc_array_index_type, "count2");
4385 gfc_add_modify (block, count1, gfc_index_zero_node);
4386 gfc_add_modify (block, count2, gfc_index_zero_node);
4388 tmp = gfc_trans_where_assign (expr1, expr2,
4393 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
4395 gfc_add_expr_to_block (block, tmp);
4400 /* Variables to control maskexpr. */
4401 count1 = gfc_create_var (gfc_array_index_type, "count1");
4402 count2 = gfc_create_var (gfc_array_index_type, "count2");
4403 gfc_add_modify (block, count1, gfc_index_zero_node);
4404 gfc_add_modify (block, count2, gfc_index_zero_node);
4406 tmp = gfc_trans_where_assign (expr1, expr2,
4410 gfc_add_expr_to_block (block, tmp);
4415 /* WHERE or WHERE construct is part of a where-body-construct. */
4417 gfc_trans_where_2 (cnext, cmask, invert,
4418 nested_forall_info, block);
4425 /* The next statement within the same where-body-construct. */
4426 cnext = cnext->next;
4428 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
4429 cblock = cblock->block;
4430 if (mask == NULL_TREE)
4432 /* If we're the initial WHERE, we can simply invert the sense
4433 of the current mask to obtain the "mask" for the remaining
4440 /* Otherwise, for nested WHERE's we need to use the pending mask. */
4446 /* If we allocated a pending mask array, deallocate it now. */
4449 tmp = gfc_call_free (ppmask);
4450 gfc_add_expr_to_block (block, tmp);
4453 /* If we allocated a current mask array, deallocate it now. */
4456 tmp = gfc_call_free (pcmask);
4457 gfc_add_expr_to_block (block, tmp);
4461 /* Translate a simple WHERE construct or statement without dependencies.
4462 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
4463 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
4464 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
4467 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
4469 stmtblock_t block, body;
4470 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
4471 tree tmp, cexpr, tstmt, estmt;
4472 gfc_ss *css, *tdss, *tsss;
4473 gfc_se cse, tdse, tsse, edse, esse;
4478 /* Allow the scalarizer to workshare simple where loops. */
4479 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4480 ompws_flags |= OMPWS_SCALARIZER_WS;
4482 cond = cblock->expr1;
4483 tdst = cblock->next->expr1;
4484 tsrc = cblock->next->expr2;
4485 edst = eblock ? eblock->next->expr1 : NULL;
4486 esrc = eblock ? eblock->next->expr2 : NULL;
4488 gfc_start_block (&block);
4489 gfc_init_loopinfo (&loop);
4491 /* Handle the condition. */
4492 gfc_init_se (&cse, NULL);
4493 css = gfc_walk_expr (cond);
4494 gfc_add_ss_to_loop (&loop, css);
4496 /* Handle the then-clause. */
4497 gfc_init_se (&tdse, NULL);
4498 gfc_init_se (&tsse, NULL);
4499 tdss = gfc_walk_expr (tdst);
4500 tsss = gfc_walk_expr (tsrc);
4501 if (tsss == gfc_ss_terminator)
4503 tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
4506 gfc_add_ss_to_loop (&loop, tdss);
4507 gfc_add_ss_to_loop (&loop, tsss);
4511 /* Handle the else clause. */
4512 gfc_init_se (&edse, NULL);
4513 gfc_init_se (&esse, NULL);
4514 edss = gfc_walk_expr (edst);
4515 esss = gfc_walk_expr (esrc);
4516 if (esss == gfc_ss_terminator)
4518 esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
4521 gfc_add_ss_to_loop (&loop, edss);
4522 gfc_add_ss_to_loop (&loop, esss);
4525 gfc_conv_ss_startstride (&loop);
4526 gfc_conv_loop_setup (&loop, &tdst->where);
4528 gfc_mark_ss_chain_used (css, 1);
4529 gfc_mark_ss_chain_used (tdss, 1);
4530 gfc_mark_ss_chain_used (tsss, 1);
4533 gfc_mark_ss_chain_used (edss, 1);
4534 gfc_mark_ss_chain_used (esss, 1);
4537 gfc_start_scalarized_body (&loop, &body);
4539 gfc_copy_loopinfo_to_se (&cse, &loop);
4540 gfc_copy_loopinfo_to_se (&tdse, &loop);
4541 gfc_copy_loopinfo_to_se (&tsse, &loop);
4547 gfc_copy_loopinfo_to_se (&edse, &loop);
4548 gfc_copy_loopinfo_to_se (&esse, &loop);
4553 gfc_conv_expr (&cse, cond);
4554 gfc_add_block_to_block (&body, &cse.pre);
4557 gfc_conv_expr (&tsse, tsrc);
4558 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
4559 gfc_conv_tmp_array_ref (&tdse);
4561 gfc_conv_expr (&tdse, tdst);
4565 gfc_conv_expr (&esse, esrc);
4566 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
4567 gfc_conv_tmp_array_ref (&edse);
4569 gfc_conv_expr (&edse, edst);
4572 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
4573 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
4575 : build_empty_stmt (input_location);
4576 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
4577 gfc_add_expr_to_block (&body, tmp);
4578 gfc_add_block_to_block (&body, &cse.post);
4580 gfc_trans_scalarizing_loops (&loop, &body);
4581 gfc_add_block_to_block (&block, &loop.pre);
4582 gfc_add_block_to_block (&block, &loop.post);
4583 gfc_cleanup_loop (&loop);
4585 return gfc_finish_block (&block);
4588 /* As the WHERE or WHERE construct statement can be nested, we call
4589 gfc_trans_where_2 to do the translation, and pass the initial
4590 NULL values for both the control mask and the pending control mask. */
4593 gfc_trans_where (gfc_code * code)
4599 cblock = code->block;
4601 && cblock->next->op == EXEC_ASSIGN
4602 && !cblock->next->next)
4604 eblock = cblock->block;
4607 /* A simple "WHERE (cond) x = y" statement or block is
4608 dependence free if cond is not dependent upon writing x,
4609 and the source y is unaffected by the destination x. */
4610 if (!gfc_check_dependency (cblock->next->expr1,
4612 && !gfc_check_dependency (cblock->next->expr1,
4613 cblock->next->expr2, 0))
4614 return gfc_trans_where_3 (cblock, NULL);
4616 else if (!eblock->expr1
4619 && eblock->next->op == EXEC_ASSIGN
4620 && !eblock->next->next)
4622 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
4623 block is dependence free if cond is not dependent on writes
4624 to x1 and x2, y1 is not dependent on writes to x2, and y2
4625 is not dependent on writes to x1, and both y's are not
4626 dependent upon their own x's. In addition to this, the
4627 final two dependency checks below exclude all but the same
4628 array reference if the where and elswhere destinations
4629 are the same. In short, this is VERY conservative and this
4630 is needed because the two loops, required by the standard
4631 are coalesced in gfc_trans_where_3. */
4632 if (!gfc_check_dependency(cblock->next->expr1,
4634 && !gfc_check_dependency(eblock->next->expr1,
4636 && !gfc_check_dependency(cblock->next->expr1,
4637 eblock->next->expr2, 1)
4638 && !gfc_check_dependency(eblock->next->expr1,
4639 cblock->next->expr2, 1)
4640 && !gfc_check_dependency(cblock->next->expr1,
4641 cblock->next->expr2, 1)
4642 && !gfc_check_dependency(eblock->next->expr1,
4643 eblock->next->expr2, 1)
4644 && !gfc_check_dependency(cblock->next->expr1,
4645 eblock->next->expr1, 0)
4646 && !gfc_check_dependency(eblock->next->expr1,
4647 cblock->next->expr1, 0))
4648 return gfc_trans_where_3 (cblock, eblock);
4652 gfc_start_block (&block);
4654 gfc_trans_where_2 (code, NULL, false, NULL, &block);
4656 return gfc_finish_block (&block);
4660 /* CYCLE a DO loop. The label decl has already been created by
4661 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
4662 node at the head of the loop. We must mark the label as used. */
4665 gfc_trans_cycle (gfc_code * code)
4669 cycle_label = code->ext.which_construct->cycle_label;
4670 gcc_assert (cycle_label);
4672 TREE_USED (cycle_label) = 1;
4673 return build1_v (GOTO_EXPR, cycle_label);
4677 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
4678 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
4682 gfc_trans_exit (gfc_code * code)
4686 exit_label = code->ext.which_construct->exit_label;
4687 gcc_assert (exit_label);
4689 TREE_USED (exit_label) = 1;
4690 return build1_v (GOTO_EXPR, exit_label);
4694 /* Translate the ALLOCATE statement. */
4697 gfc_trans_allocate (gfc_code * code)
4717 if (!code->ext.alloc.list)
4720 stat = tmp = memsz = NULL_TREE;
4721 label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
4723 gfc_init_block (&block);
4724 gfc_init_block (&post);
4726 /* STAT= (and maybe ERRMSG=) is present. */
4730 tree gfc_int4_type_node = gfc_get_int_type (4);
4731 stat = gfc_create_var (gfc_int4_type_node, "stat");
4733 /* ERRMSG= only makes sense with STAT=. */
4736 gfc_init_se (&se, NULL);
4737 gfc_conv_expr_lhs (&se, code->expr2);
4739 errlen = gfc_get_expr_charlen (code->expr2);
4740 errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
4744 errmsg = null_pointer_node;
4745 errlen = build_int_cst (gfc_charlen_type_node, 0);
4748 /* GOTO destinations. */
4749 label_errmsg = gfc_build_label_decl (NULL_TREE);
4750 label_finish = gfc_build_label_decl (NULL_TREE);
4751 TREE_USED (label_errmsg) = 1;
4752 TREE_USED (label_finish) = 1;
4758 for (al = code->ext.alloc.list; al != NULL; al = al->next)
4760 expr = gfc_copy_expr (al->expr);
4762 if (expr->ts.type == BT_CLASS)
4763 gfc_add_data_component (expr);
4765 gfc_init_se (&se, NULL);
4767 se.want_pointer = 1;
4768 se.descriptor_only = 1;
4769 gfc_conv_expr (&se, expr);
4771 if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
4773 /* A scalar or derived type. */
4775 /* Determine allocate size. */
4776 if (al->expr->ts.type == BT_CLASS && code->expr3)
4778 if (code->expr3->ts.type == BT_CLASS)
4780 sz = gfc_copy_expr (code->expr3);
4781 gfc_add_vptr_component (sz);
4782 gfc_add_size_component (sz);
4783 gfc_init_se (&se_sz, NULL);
4784 gfc_conv_expr (&se_sz, sz);
4789 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
4791 else if (al->expr->ts.type == BT_CHARACTER
4792 && al->expr->ts.deferred && code->expr3)
4794 if (!code->expr3->ts.u.cl->backend_decl)
4796 /* Convert and use the length expression. */
4797 gfc_init_se (&se_sz, NULL);
4798 if (code->expr3->expr_type == EXPR_VARIABLE
4799 || code->expr3->expr_type == EXPR_CONSTANT)
4801 gfc_conv_expr (&se_sz, code->expr3);
4802 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4804 = gfc_evaluate_now (se_sz.string_length, &se.pre);
4805 gfc_add_block_to_block (&se.pre, &se_sz.post);
4806 memsz = se_sz.string_length;
4808 else if (code->expr3->mold
4809 && code->expr3->ts.u.cl
4810 && code->expr3->ts.u.cl->length)
4812 gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
4813 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4814 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
4815 gfc_add_block_to_block (&se.pre, &se_sz.post);
4820 /* This is would be inefficient and possibly could
4821 generate wrong code if the result were not stored
4823 if (slen3 == NULL_TREE)
4825 gfc_conv_expr (&se_sz, code->expr3);
4826 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4827 expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
4828 gfc_add_block_to_block (&post, &se_sz.post);
4829 slen3 = gfc_evaluate_now (se_sz.string_length,
4836 /* Otherwise use the stored string length. */
4837 memsz = code->expr3->ts.u.cl->backend_decl;
4838 tmp = al->expr->ts.u.cl->backend_decl;
4840 /* Store the string length. */
4841 if (tmp && TREE_CODE (tmp) == VAR_DECL)
4842 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
4845 /* Convert to size in bytes, using the character KIND. */
4846 tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
4847 tmp = TYPE_SIZE_UNIT (tmp);
4848 memsz = fold_build2_loc (input_location, MULT_EXPR,
4849 TREE_TYPE (tmp), tmp,
4850 fold_convert (TREE_TYPE (tmp), memsz));
4852 else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
4854 gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
4855 gfc_init_se (&se_sz, NULL);
4856 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
4857 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4858 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
4859 gfc_add_block_to_block (&se.pre, &se_sz.post);
4860 /* Store the string length. */
4861 tmp = al->expr->ts.u.cl->backend_decl;
4862 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
4864 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
4865 tmp = TYPE_SIZE_UNIT (tmp);
4866 memsz = fold_build2_loc (input_location, MULT_EXPR,
4867 TREE_TYPE (tmp), tmp,
4868 fold_convert (TREE_TYPE (se_sz.expr),
4871 else if (code->ext.alloc.ts.type != BT_UNKNOWN)
4872 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
4874 memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
4876 if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
4878 memsz = se.string_length;
4880 /* Convert to size in bytes, using the character KIND. */
4881 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
4882 tmp = TYPE_SIZE_UNIT (tmp);
4883 memsz = fold_build2_loc (input_location, MULT_EXPR,
4884 TREE_TYPE (tmp), tmp,
4885 fold_convert (TREE_TYPE (tmp), memsz));
4888 /* Allocate - for non-pointers with re-alloc checking. */
4889 if (gfc_expr_attr (expr).allocatable)
4890 gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
4891 stat, errmsg, errlen, expr);
4893 gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
4895 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
4897 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
4898 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
4899 gfc_add_expr_to_block (&se.pre, tmp);
4903 gfc_add_block_to_block (&block, &se.pre);
4905 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
4908 /* The coarray library already sets the errmsg. */
4909 if (gfc_option.coarray == GFC_FCOARRAY_LIB
4910 && gfc_expr_attr (expr).codimension)
4911 tmp = build1_v (GOTO_EXPR, label_finish);
4913 tmp = build1_v (GOTO_EXPR, label_errmsg);
4915 parm = fold_build2_loc (input_location, NE_EXPR,
4916 boolean_type_node, stat,
4917 build_int_cst (TREE_TYPE (stat), 0));
4918 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4919 gfc_unlikely(parm), tmp,
4920 build_empty_stmt (input_location));
4921 gfc_add_expr_to_block (&block, tmp);
4924 if (code->expr3 && !code->expr3->mold)
4926 /* Initialization via SOURCE block
4927 (or static default initializer). */
4928 gfc_expr *rhs = gfc_copy_expr (code->expr3);
4929 if (al->expr->ts.type == BT_CLASS)
4932 gfc_actual_arglist *actual;
4934 gfc_init_se (&call, NULL);
4935 /* Do a polymorphic deep copy. */
4936 actual = gfc_get_actual_arglist ();
4937 actual->expr = gfc_copy_expr (rhs);
4938 if (rhs->ts.type == BT_CLASS)
4939 gfc_add_data_component (actual->expr);
4940 actual->next = gfc_get_actual_arglist ();
4941 actual->next->expr = gfc_copy_expr (al->expr);
4942 gfc_add_data_component (actual->next->expr);
4943 if (rhs->ts.type == BT_CLASS)
4945 ppc = gfc_copy_expr (rhs);
4946 gfc_add_vptr_component (ppc);
4949 ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
4950 gfc_add_component_ref (ppc, "_copy");
4951 gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
4953 gfc_add_expr_to_block (&call.pre, call.expr);
4954 gfc_add_block_to_block (&call.pre, &call.post);
4955 tmp = gfc_finish_block (&call.pre);
4957 else if (expr3 != NULL_TREE)
4959 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
4960 gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
4961 slen3, expr3, code->expr3->ts.kind);
4966 /* Switch off automatic reallocation since we have just done
4968 int realloc_lhs = gfc_option.flag_realloc_lhs;
4969 gfc_option.flag_realloc_lhs = 0;
4970 tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
4972 gfc_option.flag_realloc_lhs = realloc_lhs;
4974 gfc_free_expr (rhs);
4975 gfc_add_expr_to_block (&block, tmp);
4977 else if (code->expr3 && code->expr3->mold
4978 && code->expr3->ts.type == BT_CLASS)
4980 /* Default-initialization via MOLD (polymorphic). */
4981 gfc_expr *rhs = gfc_copy_expr (code->expr3);
4983 gfc_add_vptr_component (rhs);
4984 gfc_add_def_init_component (rhs);
4985 gfc_init_se (&dst, NULL);
4986 gfc_init_se (&src, NULL);
4987 gfc_conv_expr (&dst, expr);
4988 gfc_conv_expr (&src, rhs);
4989 gfc_add_block_to_block (&block, &src.pre);
4990 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
4991 gfc_add_expr_to_block (&block, tmp);
4992 gfc_free_expr (rhs);
4995 /* Allocation of CLASS entities. */
4996 gfc_free_expr (expr);
4998 if (expr->ts.type == BT_CLASS)
5003 /* Initialize VPTR for CLASS objects. */
5004 lhs = gfc_expr_to_initialize (expr);
5005 gfc_add_vptr_component (lhs);
5007 if (code->expr3 && code->expr3->ts.type == BT_CLASS)
5009 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5010 rhs = gfc_copy_expr (code->expr3);
5011 gfc_add_vptr_component (rhs);
5012 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5013 gfc_add_expr_to_block (&block, tmp);
5014 gfc_free_expr (rhs);
5018 /* VPTR is fixed at compile time. */
5022 ts = &code->expr3->ts;
5023 else if (expr->ts.type == BT_DERIVED)
5025 else if (code->ext.alloc.ts.type == BT_DERIVED)
5026 ts = &code->ext.alloc.ts;
5027 else if (expr->ts.type == BT_CLASS)
5028 ts = &CLASS_DATA (expr)->ts;
5032 if (ts->type == BT_DERIVED)
5034 vtab = gfc_find_derived_vtab (ts->u.derived);
5036 gfc_init_se (&lse, NULL);
5037 lse.want_pointer = 1;
5038 gfc_conv_expr (&lse, lhs);
5039 tmp = gfc_build_addr_expr (NULL_TREE,
5040 gfc_get_symbol_decl (vtab));
5041 gfc_add_modify (&block, lse.expr,
5042 fold_convert (TREE_TYPE (lse.expr), tmp));
5045 gfc_free_expr (lhs);
5050 /* STAT (ERRMSG only makes sense with STAT). */
5053 tmp = build1_v (LABEL_EXPR, label_errmsg);
5054 gfc_add_expr_to_block (&block, tmp);
5060 /* A better error message may be possible, but not required. */
5061 const char *msg = "Attempt to allocate an allocated object";
5064 gfc_init_se (&se, NULL);
5065 gfc_conv_expr_lhs (&se, code->expr2);
5067 errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
5069 gfc_add_modify (&block, errmsg,
5070 gfc_build_addr_expr (pchar_type_node,
5071 gfc_build_localized_cstring_const (msg)));
5073 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5074 dlen = gfc_get_expr_charlen (code->expr2);
5075 slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
5078 dlen = build_call_expr_loc (input_location,
5079 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5080 gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
5082 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5083 build_int_cst (TREE_TYPE (stat), 0));
5085 tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
5087 gfc_add_expr_to_block (&block, tmp);
5090 /* STAT (ERRMSG only makes sense with STAT). */
5093 tmp = build1_v (LABEL_EXPR, label_finish);
5094 gfc_add_expr_to_block (&block, tmp);
5100 gfc_init_se (&se, NULL);
5101 gfc_conv_expr_lhs (&se, code->expr1);
5102 tmp = convert (TREE_TYPE (se.expr), stat);
5103 gfc_add_modify (&block, se.expr, tmp);
5106 gfc_add_block_to_block (&block, &se.post);
5107 gfc_add_block_to_block (&block, &post);
5109 return gfc_finish_block (&block);
5113 /* Translate a DEALLOCATE statement. */
5116 gfc_trans_deallocate (gfc_code *code)
5120 tree apstat, astat, pstat, stat, tmp;
5123 pstat = apstat = stat = astat = tmp = NULL_TREE;
5125 gfc_start_block (&block);
5127 /* Count the number of failed deallocations. If deallocate() was
5128 called with STAT= , then set STAT to the count. If deallocate
5129 was called with ERRMSG, then set ERRMG to a string. */
5130 if (code->expr1 || code->expr2)
5132 tree gfc_int4_type_node = gfc_get_int_type (4);
5134 stat = gfc_create_var (gfc_int4_type_node, "stat");
5135 pstat = gfc_build_addr_expr (NULL_TREE, stat);
5137 /* Running total of possible deallocation failures. */
5138 astat = gfc_create_var (gfc_int4_type_node, "astat");
5139 apstat = gfc_build_addr_expr (NULL_TREE, astat);
5141 /* Initialize astat to 0. */
5142 gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
5145 for (al = code->ext.alloc.list; al != NULL; al = al->next)
5147 gfc_expr *expr = gfc_copy_expr (al->expr);
5148 gcc_assert (expr->expr_type == EXPR_VARIABLE);
5150 if (expr->ts.type == BT_CLASS)
5151 gfc_add_data_component (expr);
5153 gfc_init_se (&se, NULL);
5154 gfc_start_block (&se.pre);
5156 se.want_pointer = 1;
5157 se.descriptor_only = 1;
5158 gfc_conv_expr (&se, expr);
5160 if (expr->rank || gfc_expr_attr (expr).codimension)
5162 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
5165 gfc_ref *last = NULL;
5166 for (ref = expr->ref; ref; ref = ref->next)
5167 if (ref->type == REF_COMPONENT)
5170 /* Do not deallocate the components of a derived type
5171 ultimate pointer component. */
5172 if (!(last && last->u.c.component->attr.pointer)
5173 && !(!last && expr->symtree->n.sym->attr.pointer))
5175 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
5177 gfc_add_expr_to_block (&se.pre, tmp);
5180 tmp = gfc_array_deallocate (se.expr, pstat, expr);
5181 gfc_add_expr_to_block (&se.pre, tmp);
5185 tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
5187 gfc_add_expr_to_block (&se.pre, tmp);
5189 /* Set to zero after deallocation. */
5190 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5192 build_int_cst (TREE_TYPE (se.expr), 0));
5193 gfc_add_expr_to_block (&se.pre, tmp);
5195 if (al->expr->ts.type == BT_CLASS)
5197 /* Reset _vptr component to declared type. */
5198 gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
5199 gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
5200 gfc_add_vptr_component (lhs);
5201 rhs = gfc_lval_expr_from_sym (vtab);
5202 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5203 gfc_add_expr_to_block (&se.pre, tmp);
5204 gfc_free_expr (lhs);
5205 gfc_free_expr (rhs);
5209 /* Keep track of the number of failed deallocations by adding stat
5210 of the last deallocation to the running total. */
5211 if (code->expr1 || code->expr2)
5213 apstat = fold_build2_loc (input_location, PLUS_EXPR,
5214 TREE_TYPE (stat), astat, stat);
5215 gfc_add_modify (&se.pre, astat, apstat);
5218 tmp = gfc_finish_block (&se.pre);
5219 gfc_add_expr_to_block (&block, tmp);
5220 gfc_free_expr (expr);
5226 gfc_init_se (&se, NULL);
5227 gfc_conv_expr_lhs (&se, code->expr1);
5228 tmp = convert (TREE_TYPE (se.expr), astat);
5229 gfc_add_modify (&block, se.expr, tmp);
5235 /* A better error message may be possible, but not required. */
5236 const char *msg = "Attempt to deallocate an unallocated object";
5237 tree errmsg, slen, dlen;
5239 gfc_init_se (&se, NULL);
5240 gfc_conv_expr_lhs (&se, code->expr2);
5242 errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
5244 gfc_add_modify (&block, errmsg,
5245 gfc_build_addr_expr (pchar_type_node,
5246 gfc_build_localized_cstring_const (msg)));
5248 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5249 dlen = gfc_get_expr_charlen (code->expr2);
5250 slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
5253 dlen = build_call_expr_loc (input_location,
5254 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5255 gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
5257 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat,
5258 build_int_cst (TREE_TYPE (astat), 0));
5260 tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
5262 gfc_add_expr_to_block (&block, tmp);
5265 return gfc_finish_block (&block);
5268 #include "gt-fortran-trans-stmt.h"