X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-stmt.c;h=630816ed401504797203a7a76b93868edc2ac27c;hb=071be23809d255227730595ebfae85181b744ac8;hp=caa9572db5e496abcb2a4c96a4f912f86d813800;hpb=1557756e1e4954779caa11f9106651487b328ee2;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index caa9572db5e..630816ed401 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1,5 +1,6 @@ /* Statement translation -- generate GCC trees from gfc_code. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -118,7 +119,7 @@ gfc_trans_label_assign (gfc_code * code) gfc_expr *format = code->label1->format; label_len = format->value.character.length; - len_tree = build_int_cst (NULL_TREE, label_len); + len_tree = build_int_cst (gfc_charlen_type_node, label_len); label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1, format->value.character.string); label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); @@ -177,6 +178,41 @@ gfc_trans_entry (gfc_code * code) } +/* Replace a gfc_ss structure by another both in the gfc_se struct + and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies + to replace a variable ss by the corresponding temporary. */ + +static void +replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss) +{ + gfc_ss **sess, **loopss; + + /* The old_ss is a ss for a single variable. */ + gcc_assert (old_ss->info->type == GFC_SS_SECTION); + + for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next)) + if (*sess == old_ss) + break; + gcc_assert (*sess != gfc_ss_terminator); + + *sess = new_ss; + new_ss->next = old_ss->next; + + + for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator; + loopss = &((*loopss)->loop_chain)) + if (*loopss == old_ss) + break; + gcc_assert (*loopss != gfc_ss_terminator); + + *loopss = new_ss; + new_ss->loop_chain = old_ss->loop_chain; + new_ss->loop = old_ss->loop; + + gfc_free_ss (old_ss); +} + + /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of elemental subroutines. Make temporaries for output arguments if any such dependencies are found. Output arguments are chosen because internal_unpack @@ -189,15 +225,10 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, gfc_actual_arglist *arg0; gfc_expr *e; gfc_formal_arglist *formal; - gfc_loopinfo tmp_loop; gfc_se parmse; gfc_ss *ss; - gfc_ss_info *info; gfc_symbol *fsym; - gfc_ref *ref; - int n; tree data; - tree offset; tree size; tree tmp; @@ -216,14 +247,9 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, continue; /* Obtain the info structure for the current argument. */ - info = NULL; for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) - { - if (ss->expr != e) - continue; - info = &ss->data.info; + if (ss->info->expr == e) break; - } /* If there is a dependency, create a temporary and use it instead of the variable. */ @@ -236,48 +262,17 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, { tree initial, temptype; stmtblock_t temp_post; + gfc_ss *tmp_ss; - /* Make a local loopinfo for the temporary creation, so that - none of the other ss->info's have to be renormalized. */ - gfc_init_loopinfo (&tmp_loop); - for (n = 0; n < info->dimen; n++) - { - tmp_loop.to[n] = loopse->loop->to[n]; - tmp_loop.from[n] = loopse->loop->from[n]; - tmp_loop.order[n] = loopse->loop->order[n]; - } + tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen, + GFC_SS_SECTION); + gfc_mark_ss_chain_used (tmp_ss, 1); + tmp_ss->info->expr = ss->info->expr; + replace_ss (loopse, ss, tmp_ss); /* Obtain the argument descriptor for unpacking. */ gfc_init_se (&parmse, NULL); parmse.want_pointer = 1; - - /* The scalarizer introduces some specific peculiarities when - handling elemental subroutines; the stride can be needed up to - the dim_array - 1, rather than dim_loop - 1 to calculate - offsets outside the loop. For this reason, we make sure that - the descriptor has the dimensionality of the array by converting - trailing elements into ranges with end = start. */ - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) - break; - - if (ref) - { - bool seen_range = false; - for (n = 0; n < ref->u.ar.dimen; n++) - { - if (ref->u.ar.dimen_type[n] == DIMEN_RANGE) - seen_range = true; - - if (!seen_range - || ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) - continue; - - ref->u.ar.end[n] = gfc_copy_expr (ref->u.ar.start[n]); - ref->u.ar.dimen_type[n] = DIMEN_RANGE; - } - } - gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); gfc_add_block_to_block (&se->pre, &parmse.pre); @@ -287,19 +282,31 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, || (fsym->ts.type ==BT_DERIVED && fsym->attr.intent == INTENT_OUT)) initial = parmse.expr; + /* For class expressions, we always initialize with the copy of + the values. */ + else if (e->ts.type == BT_CLASS) + initial = parmse.expr; else initial = NULL_TREE; - /* Find the type of the temporary to create; we don't use the type - of e itself as this breaks for subcomponent-references in e (where - the type of e is that of the final reference, but parmse.expr's - type corresponds to the full derived-type). */ - /* TODO: Fix this somehow so we don't need a temporary of the whole - array but instead only the components referenced. */ - temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ - gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); - temptype = TREE_TYPE (temptype); - temptype = gfc_get_element_type (temptype); + if (e->ts.type != BT_CLASS) + { + /* Find the type of the temporary to create; we don't use the type + of e itself as this breaks for subcomponent-references in e + (where the type of e is that of the final reference, but + parmse.expr's type corresponds to the full derived-type). */ + /* TODO: Fix this somehow so we don't need a temporary of the whole + array but instead only the components referenced. */ + temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ + gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); + temptype = TREE_TYPE (temptype); + temptype = gfc_get_element_type (temptype); + } + + else + /* For class arrays signal that the size of the dynamic type has to + be obtained from the vtable, using the 'initial' expression. */ + temptype = NULL_TREE; /* Generate the temporary. Cleaning up the temporary should be the very last thing done, so we add the code to a new block and add it @@ -307,33 +314,30 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, size = gfc_create_var (gfc_array_index_type, NULL); data = gfc_create_var (pvoid_type_node, NULL); gfc_init_block (&temp_post); - tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, - &tmp_loop, info, temptype, - initial, - false, true, false, - &arg->expr->where); + tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss, + temptype, initial, false, true, + false, &arg->expr->where); gfc_add_modify (&se->pre, size, tmp); - tmp = fold_convert (pvoid_type_node, info->data); + tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data); gfc_add_modify (&se->pre, data, tmp); - /* Calculate the offset for the temporary. */ - offset = gfc_index_zero_node; - for (n = 0; n < info->dimen; n++) + /* Update other ss' delta. */ + gfc_set_delta (loopse->loop); + + /* Copy the result back using unpack..... */ + if (e->ts.type != BT_CLASS) + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_unpack, 2, parmse.expr, data); + else { - tmp = gfc_conv_descriptor_stride_get (info->descriptor, - gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - loopse->loop->from[n], tmp); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, tmp); + /* ... except for class results where the copy is + unconditional. */ + tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); + tmp = gfc_conv_descriptor_data_get (tmp); + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), + 3, tmp, data, size); } - info->offset = gfc_create_var (gfc_array_index_type, NULL); - gfc_add_modify (&se->pre, info->offset, offset); - - /* Copy the result back using unpack. */ - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, parmse.expr, data); gfc_add_expr_to_block (&se->post, tmp); /* parmse.pre is already added above. */ @@ -344,6 +348,27 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, } +/* Get the interface symbol for the procedure corresponding to the given call. + We can't get the procedure symbol directly as we have to handle the case + of (deferred) type-bound procedures. */ + +static gfc_symbol * +get_proc_ifc_for_call (gfc_code *c) +{ + gfc_symbol *sym; + + gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL); + + sym = gfc_get_proc_ifc_for_expr (c->expr1); + + /* Fall back/last resort try. */ + if (sym == NULL) + sym = c->resolved_sym; + + return sym; +} + + /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree @@ -367,7 +392,9 @@ gfc_trans_call (gfc_code * code, bool dependency_check, ss = gfc_ss_terminator; if (code->resolved_sym->attr.elemental) - ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE); + ss = gfc_walk_elemental_function_args (ss, code->ext.actual, + get_proc_ifc_for_call (code), + GFC_SS_REFERENCE); /* Is not an elemental subroutine call with array valued arguments. */ if (ss == gfc_ss_terminator) @@ -597,29 +624,49 @@ gfc_trans_stop (gfc_code *code, bool error_stop) gfc_init_se (&se, NULL); gfc_start_block (&se.pre); + if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop) + { + /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */ + tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); + tmp = build_call_expr_loc (input_location, tmp, 0); + gfc_add_expr_to_block (&se.pre, tmp); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0); + gfc_add_expr_to_block (&se.pre, tmp); + } + if (code->expr1 == NULL) { tmp = build_int_cst (gfc_int4_type_node, 0); tmp = build_call_expr_loc (input_location, - error_stop ? gfor_fndecl_error_stop_string + error_stop + ? (gfc_option.coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop_str + : gfor_fndecl_error_stop_string) : gfor_fndecl_stop_string, - 2, build_int_cst (pchar_type_node, 0), tmp); + 2, build_int_cst (pchar_type_node, 0), tmp); } else if (code->expr1->ts.type == BT_INTEGER) { gfc_conv_expr (&se, code->expr1); tmp = build_call_expr_loc (input_location, - error_stop ? gfor_fndecl_error_stop_numeric - : gfor_fndecl_stop_numeric, 1, + error_stop + ? (gfc_option.coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop + : gfor_fndecl_error_stop_numeric) + : gfor_fndecl_stop_numeric_f08, 1, fold_convert (gfc_int4_type_node, se.expr)); } else { gfc_conv_expr_reference (&se, code->expr1); tmp = build_call_expr_loc (input_location, - error_stop ? gfor_fndecl_error_stop_string + error_stop + ? (gfc_option.coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop_str + : gfor_fndecl_error_stop_string) : gfor_fndecl_stop_string, - 2, se.expr, se.string_length); + 2, se.expr, se.string_length); } gfc_add_expr_to_block (&se.pre, tmp); @@ -631,14 +678,95 @@ gfc_trans_stop (gfc_code *code, bool error_stop) tree -gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) +gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED) { - gfc_se se; + gfc_se se, argse; + tree stat = NULL_TREE, lock_acquired = NULL_TREE; - if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) + /* Short cut: For single images without STAT= or LOCK_ACQUIRED + return early. (ERRMSG= is always untouched for -fcoarray=single.) */ + if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB) + return NULL_TREE; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + if (code->expr2) { - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + stat = argse.expr; + } + + if (code->expr4) + { + gcc_assert (code->expr4->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr4); + lock_acquired = argse.expr; + } + + if (stat != NULL_TREE) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); + + if (lock_acquired != NULL_TREE) + gfc_add_modify (&se.pre, lock_acquired, + fold_convert (TREE_TYPE (lock_acquired), + boolean_true_node)); + + return gfc_finish_block (&se.pre); +} + + +tree +gfc_trans_sync (gfc_code *code, gfc_exec_op type) +{ + gfc_se se, argse; + tree tmp; + tree images = NULL_TREE, stat = NULL_TREE, + errmsg = NULL_TREE, errmsglen = NULL_TREE; + + /* Short cut: For single images without bound checking or without STAT=, + return early. (ERRMSG= is always untouched for -fcoarray=single.) */ + if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && gfc_option.coarray != GFC_FCOARRAY_LIB) + return NULL_TREE; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + if (code->expr1 && code->expr1->rank == 0) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + images = argse.expr; + } + + if (code->expr2) + { + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + stat = argse.expr; + } + else + stat = null_pointer_node; + + if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB + && type != EXEC_SYNC_MEMORY) + { + gcc_assert (code->expr3->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->expr3); + gfc_conv_string_parameter (&argse); + errmsg = gfc_build_addr_expr (NULL, argse.expr); + errmsglen = argse.string_length; + } + else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY) + { + errmsg = null_pointer_node; + errmsglen = build_int_cst (integer_type_node, 0); } /* Check SYNC IMAGES(imageset) for valid image index. @@ -647,27 +775,141 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) && code->expr1->rank == 0) { tree cond; - gfc_conv_expr (&se, code->expr1); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - se.expr, build_int_cst (TREE_TYPE (se.expr), 1)); + if (gfc_option.coarray != GFC_FCOARRAY_LIB) + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + images, build_int_cst (TREE_TYPE (images), 1)); + else + { + tree cond2; + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + images, gfort_gvar_caf_num_images); + cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + images, + build_int_cst (TREE_TYPE (images), 1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, cond2); + } gfc_trans_runtime_check (true, false, cond, &se.pre, &code->expr1->where, "Invalid image number " "%d in SYNC IMAGES", fold_convert (integer_type_node, se.expr)); } - /* If STAT is present, set it to zero. */ - if (code->expr2) + /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the + image control statements SYNC IMAGES and SYNC ALL. */ + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); + tmp = build_call_expr_loc (input_location, tmp, 0); + gfc_add_expr_to_block (&se.pre, tmp); + } + + if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY) { - gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); - gfc_conv_expr (&se, code->expr2); - gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + /* Set STAT to zero. */ + if (code->expr2) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); } + else if (type == EXEC_SYNC_ALL) + { + /* SYNC ALL => stat == null_pointer_node + SYNC ALL(stat=s) => stat has an integer type - if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) - return gfc_finish_block (&se.pre); - - return NULL_TREE; + If "stat" has the wrong integer type, use a temp variable of + the right type and later cast the result back into "stat". */ + if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) + { + if (TREE_TYPE (stat) == integer_type_node) + stat = gfc_build_addr_expr (NULL, stat); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, stat, errmsg, errmsglen); + gfc_add_expr_to_block (&se.pre, tmp); + } + else + { + tree tmp_stat = gfc_create_var (integer_type_node, "stat"); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, gfc_build_addr_expr (NULL, tmp_stat), + errmsg, errmsglen); + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_modify (&se.pre, stat, + fold_convert (TREE_TYPE (stat), tmp_stat)); + } + } + else + { + tree len; + + gcc_assert (type == EXEC_SYNC_IMAGES); + + if (!code->expr1) + { + len = build_int_cst (integer_type_node, -1); + images = null_pointer_node; + } + else if (code->expr1->rank == 0) + { + len = build_int_cst (integer_type_node, 1); + images = gfc_build_addr_expr (NULL_TREE, images); + } + else + { + /* FIXME. */ + if (code->expr1->ts.kind != gfc_c_int_kind) + gfc_fatal_error ("Sorry, only support for integer kind %d " + "implemented for image-set at %L", + gfc_c_int_kind, &code->expr1->where); + + gfc_conv_array_parameter (&se, code->expr1, + gfc_walk_expr (code->expr1), true, NULL, + NULL, &len); + images = se.expr; + + tmp = gfc_typenode_for_spec (&code->expr1->ts); + if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp)) + tmp = gfc_get_element_type (tmp); + + len = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + TREE_TYPE (len), len, + fold_convert (TREE_TYPE (len), + TYPE_SIZE_UNIT (tmp))); + len = fold_convert (integer_type_node, len); + } + + /* SYNC IMAGES(imgs) => stat == null_pointer_node + SYNC IMAGES(imgs,stat=s) => stat has an integer type + + If "stat" has the wrong integer type, use a temp variable of + the right type and later cast the result back into "stat". */ + if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) + { + if (TREE_TYPE (stat) == integer_type_node) + stat = gfc_build_addr_expr (NULL, stat); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, + 5, fold_convert (integer_type_node, len), + images, stat, errmsg, errmsglen); + gfc_add_expr_to_block (&se.pre, tmp); + } + else + { + tree tmp_stat = gfc_create_var (integer_type_node, "stat"); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, + 5, fold_convert (integer_type_node, len), + images, gfc_build_addr_expr (NULL, tmp_stat), + errmsg, errmsglen); + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_modify (&se.pre, stat, + fold_convert (TREE_TYPE (stat), tmp_stat)); + } + } + + return gfc_finish_block (&se.pre); } @@ -716,6 +958,8 @@ gfc_trans_if_1 (gfc_code * code) { gfc_se if_se; tree stmt, elsestmt; + locus saved_loc; + location_t loc; /* Check for an unconditional ELSE clause. */ if (!code->expr1) @@ -726,8 +970,17 @@ gfc_trans_if_1 (gfc_code * code) gfc_start_block (&if_se.pre); /* Calculate the IF condition expression. */ + if (code->expr1->where.lb) + { + gfc_save_backend_locus (&saved_loc); + gfc_set_backend_locus (&code->expr1->where); + } + gfc_conv_expr_val (&if_se, code->expr1); + if (code->expr1->where.lb) + gfc_restore_backend_locus (&saved_loc); + /* Translate the THEN clause. */ stmt = gfc_trans_code (code->next); @@ -738,8 +991,9 @@ gfc_trans_if_1 (gfc_code * code) elsestmt = build_empty_stmt (input_location); /* Build the condition expression and add it to the condition block. */ - stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, - if_se.expr, stmt, elsestmt); + loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location; + stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt, + elsestmt); gfc_add_expr_to_block (&if_se.pre, stmt); @@ -856,13 +1110,136 @@ gfc_trans_critical (gfc_code *code) tree tmp; gfc_start_block (&block); + + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0); + gfc_add_expr_to_block (&block, tmp); + } + tmp = gfc_trans_code (code->block->next); gfc_add_expr_to_block (&block, tmp); + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical, + 0); + gfc_add_expr_to_block (&block, tmp); + } + + return gfc_finish_block (&block); } +/* Do proper initialization for ASSOCIATE names. */ + +static void +trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) +{ + gfc_expr *e; + tree tmp; + bool class_target; + + gcc_assert (sym->assoc); + e = sym->assoc->target; + + class_target = (e->expr_type == EXPR_VARIABLE) + && (gfc_is_class_scalar_expr (e) + || gfc_is_class_array_ref (e, NULL)); + + /* Do a `pointer assignment' with updated descriptor (or assign descriptor + to array temporary) for arrays with either unknown shape or if associating + to a variable. */ + if (sym->attr.dimension && !class_target + && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) + { + gfc_se se; + gfc_ss *ss; + tree desc; + + desc = sym->backend_decl; + + /* If association is to an expression, evaluate it and create temporary. + Otherwise, get descriptor of target for pointer assignment. */ + gfc_init_se (&se, NULL); + ss = gfc_walk_expr (e); + if (sym->assoc->variable) + { + se.direct_byref = 1; + se.expr = desc; + } + gfc_conv_expr_descriptor (&se, e, ss); + + /* If we didn't already do the pointer assignment, set associate-name + descriptor to the one generated for the temporary. */ + if (!sym->assoc->variable) + { + int dim; + + gfc_add_modify (&se.pre, desc, se.expr); + + /* The generated descriptor has lower bound zero (as array + temporary), shift bounds so we get lower bounds of 1. */ + for (dim = 0; dim < e->rank; ++dim) + gfc_conv_shift_descriptor_lbound (&se.pre, desc, + dim, gfc_index_one_node); + } + + /* Done, register stuff as init / cleanup code. */ + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), + gfc_finish_block (&se.post)); + } + + /* CLASS arrays just need the descriptor to be directly assigned. */ + else if (class_target && sym->attr.dimension) + { + gfc_se se; + + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr (&se, e); + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); + + gfc_add_modify (&se.pre, sym->backend_decl, se.expr); + + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a scalar pointer assignment; this is for scalar variable targets. */ + else if (gfc_is_associate_pointer (sym)) + { + gfc_se se; + + gcc_assert (!sym->attr.dimension); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, e); + + tmp = TREE_TYPE (sym->backend_decl); + tmp = gfc_build_addr_expr (tmp, se.expr); + gfc_add_modify (&se.pre, sym->backend_decl, tmp); + + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a simple assignment. This is for scalar expressions, where we + can simply use expression assignment. */ + else + { + gfc_expr *lhs; + + lhs = gfc_lval_expr_from_sym (sym); + tmp = gfc_trans_assignment (lhs, e, false, true); + gfc_add_init_cleanup (block, tmp, NULL_TREE); + } +} + + /* Translate a BLOCK construct. This is basically what we would do for a procedure body. */ @@ -874,6 +1251,7 @@ gfc_trans_block_construct (gfc_code* code) gfc_wrapped_block block; tree exit_label; stmtblock_t body; + gfc_association_list *ass; ns = code->ext.block.ns; gcc_assert (ns); @@ -883,7 +1261,7 @@ gfc_trans_block_construct (gfc_code* code) /* Process local variables. */ gcc_assert (!sym->tlink); sym->tlink = sym; - gfc_process_block_locals (ns, code->ext.block.assoc); + gfc_process_block_locals (ns); /* Generate code including exit-label. */ gfc_init_block (&body); @@ -895,7 +1273,9 @@ gfc_trans_block_construct (gfc_code* code) /* Finish everything. */ gfc_start_wrapped_block (&block, gfc_finish_block (&body)); gfc_trans_deferred_vars (sym, &block); - + for (ass = code->ext.block.assoc; ass; ass = ass->next) + trans_associate_var (ass->st->n.sym, &block); + return gfc_finish_wrapped_block (&block); } @@ -941,17 +1321,21 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, tree saved_dovar = NULL; tree cycle_label; tree exit_label; + location_t loc; type = TREE_TYPE (dovar); + loc = code->ext.iterator->start->where.lb->location; + /* Initialize the DO variable: dovar = from. */ - gfc_add_modify (pblock, dovar, from); + gfc_add_modify_loc (loc, pblock, dovar, + fold_convert (TREE_TYPE(dovar), from)); /* Save value for do-tinkering checking. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { saved_dovar = gfc_create_var (type, ".saved_dovar"); - gfc_add_modify (pblock, saved_dovar, dovar); + gfc_add_modify_loc (loc, pblock, saved_dovar, dovar); } /* Cycle and exit statements are implemented with gotos. */ @@ -979,7 +1363,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, /* Check whether someone has modified the loop variable. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar, saved_dovar); gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, "Loop variable has been modified"); @@ -989,44 +1373,44 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, if (exit_cond) { tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, exit_cond, tmp, - build_empty_stmt (input_location)); + build_empty_stmt (loc)); gfc_add_expr_to_block (&body, tmp); } /* Evaluate the loop condition. */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, dovar, + cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar, to); - cond = gfc_evaluate_now (cond, &body); + cond = gfc_evaluate_now_loc (loc, cond, &body); /* Increment the loop variable. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar, step); - gfc_add_modify (&body, dovar, tmp); + tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); + gfc_add_modify_loc (loc, &body, dovar, tmp); if (gfc_option.rtcheck & GFC_RTCHECK_DO) - gfc_add_modify (&body, saved_dovar, dovar); + gfc_add_modify_loc (loc, &body, saved_dovar, dovar); /* The loop exit. */ - tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); TREE_USED (exit_label) = 1; - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (loc)); gfc_add_expr_to_block (&body, tmp); /* Finish the loop body. */ tmp = gfc_finish_block (&body); - tmp = build1_v (LOOP_EXPR, tmp); + tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); /* Only execute the loop if the number of iterations is positive. */ if (tree_int_cst_sgn (step) > 0) - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, dovar, + cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar, to); else - cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, dovar, + cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar, to); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, - build_empty_stmt (input_location)); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (loc)); gfc_add_expr_to_block (pblock, tmp); /* Add the exit label. */ @@ -1089,9 +1473,12 @@ gfc_trans_do (gfc_code * code, tree exit_cond) tree pos_step; stmtblock_t block; stmtblock_t body; + location_t loc; gfc_start_block (&block); + loc = code->ext.iterator->start->where.lb->location; + /* Evaluate all the expressions in the iterator. */ gfc_init_se (&se, NULL); gfc_conv_expr_lhs (&se, code->ext.iterator->var); @@ -1117,7 +1504,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) if (gfc_option.rtcheck & GFC_RTCHECK_DO) { tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step, - fold_convert (type, integer_zero_node)); + build_zero_cst (type)); gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, "DO step value is zero"); } @@ -1128,8 +1515,8 @@ gfc_trans_do (gfc_code * code, tree exit_cond) || tree_int_cst_equal (step, integer_minus_one_node))) return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond); - pos_step = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, step, - fold_convert (type, integer_zero_node)); + pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step, + build_zero_cst (type)); if (TREE_CODE (type) == INTEGER_TYPE) utype = unsigned_type_for (type); @@ -1153,7 +1540,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) if (gfc_option.rtcheck & GFC_RTCHECK_DO) { saved_dovar = gfc_create_var (type, ".saved_dovar"); - gfc_add_modify (&block, saved_dovar, dovar); + gfc_add_modify_loc (loc, &block, saved_dovar, dovar); } /* Initialize loop count and jump to exit label if the loop is empty. @@ -1179,24 +1566,25 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */ - tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, step, + tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step, build_int_cst (TREE_TYPE (step), 0)); - step_sign = fold_build3_loc (input_location, COND_EXPR, type, tmp, + step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp, build_int_cst (type, -1), build_int_cst (type, 1)); - tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, to, - from); - pos = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, - build1_v (GOTO_EXPR, exit_label), - build_empty_stmt (input_location)); + tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from); + pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, + fold_build1_loc (loc, GOTO_EXPR, void_type_node, + exit_label), + build_empty_stmt (loc)); - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, to, + tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to, from); - neg = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, - build1_v (GOTO_EXPR, exit_label), - build_empty_stmt (input_location)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, + fold_build1_loc (loc, GOTO_EXPR, void_type_node, + exit_label), + build_empty_stmt (loc)); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, pos_step, pos, neg); gfc_add_expr_to_block (&block, tmp); @@ -1204,18 +1592,14 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Calculate the loop count. to-from can overflow, so we cast to unsigned. */ - to2 = fold_build2_loc (input_location, MULT_EXPR, type, step_sign, to); - from2 = fold_build2_loc (input_location, MULT_EXPR, type, step_sign, - from); - step2 = fold_build2_loc (input_location, MULT_EXPR, type, step_sign, - step); + to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to); + from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from); + step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step); step2 = fold_convert (utype, step2); - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, to2, from2); + tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2); tmp = fold_convert (utype, tmp); - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, utype, tmp, - step2); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - countm1, tmp); + tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2); + tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp); gfc_add_expr_to_block (&block, tmp); } else @@ -1224,21 +1608,20 @@ gfc_trans_do (gfc_code * code, tree exit_cond) This would probably cause more problems that it solves when we implement "long double" types. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, to, from); - tmp = fold_build2_loc (input_location, RDIV_EXPR, type, tmp, step); - tmp = fold_build1_loc (input_location, FIX_TRUNC_EXPR, utype, tmp); + tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from); + tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step); + tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp); gfc_add_modify (&block, countm1, tmp); /* We need a special check for empty loops: empty = (step > 0 ? to < from : to > from); */ - tmp = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, - pos_step, - fold_build2_loc (input_location, LT_EXPR, + tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step, + fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from), - fold_build2_loc (input_location, GT_EXPR, + fold_build2_loc (loc, GT_EXPR, boolean_type_node, to, from)); /* If the loop is empty, go directly to the exit label. */ - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); @@ -1261,7 +1644,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Check whether someone has modified the loop variable. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, dovar, + tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar, saved_dovar); gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, "Loop variable has been modified"); @@ -1271,37 +1654,37 @@ gfc_trans_do (gfc_code * code, tree exit_cond) if (exit_cond) { tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, exit_cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); } /* Increment the loop variable. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar, step); - gfc_add_modify (&body, dovar, tmp); + tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); + gfc_add_modify_loc (loc, &body, dovar, tmp); if (gfc_option.rtcheck & GFC_RTCHECK_DO) - gfc_add_modify (&body, saved_dovar, dovar); + gfc_add_modify_loc (loc, &body, saved_dovar, dovar); /* End with the loop condition. Loop until countm1 == 0. */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, countm1, + cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1, build_int_cst (utype, 0)); - tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); + tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (loc)); gfc_add_expr_to_block (&body, tmp); /* Decrement the loop count. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, utype, countm1, + tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1, build_int_cst (utype, 1)); - gfc_add_modify (&body, countm1, tmp); + gfc_add_modify_loc (loc, &body, countm1, tmp); /* End of loop body. */ tmp = gfc_finish_block (&body); /* The for loop itself. */ - tmp = build1_v (LOOP_EXPR, tmp); + tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); gfc_add_expr_to_block (&block, tmp); /* Add the exit label. */ @@ -1359,14 +1742,15 @@ gfc_trans_do_while (gfc_code * code) gfc_init_se (&cond, NULL); gfc_conv_expr_val (&cond, code->expr1); gfc_add_block_to_block (&block, &cond.pre); - cond.expr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - boolean_type_node, cond.expr); + cond.expr = fold_build1_loc (code->expr1->where.lb->location, + TRUTH_NOT_EXPR, boolean_type_node, cond.expr); /* Build "IF (! cond) GOTO exit_label". */ tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond.expr, tmp, build_empty_stmt (input_location)); + tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR, + void_type_node, cond.expr, tmp, + build_empty_stmt (code->expr1->where.lb->location)); gfc_add_expr_to_block (&block, tmp); /* The main body of the loop. */ @@ -1385,7 +1769,8 @@ gfc_trans_do_while (gfc_code * code) gfc_init_block (&block); /* Build the loop. */ - tmp = build1_v (LOOP_EXPR, tmp); + tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR, + void_type_node, tmp); gfc_add_expr_to_block (&block, tmp); /* Add the exit label. */ @@ -1465,7 +1850,7 @@ gfc_trans_integer_select (gfc_code * code) for (c = code->block; c; c = c->block) { - for (cp = c->ext.case_list; cp; cp = cp->next) + for (cp = c->ext.block.case_list; cp; cp = cp->next) { tree low, high; tree label; @@ -1519,8 +1904,7 @@ gfc_trans_integer_select (gfc_code * code) /* Add this case label. Add parameter 'label', make it match GCC backend. */ - tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, - void_type_node, low, high, label); + tmp = build_case_label (low, high, label); gfc_add_expr_to_block (&body, tmp); } @@ -1577,7 +1961,7 @@ gfc_trans_logical_select (gfc_code * code) always executed, and we don't generate code a COND_EXPR. */ for (c = code->block; c; c = c->block) { - for (cp = c->ext.case_list; cp; cp = cp->next) + for (cp = c->ext.block.case_list; cp; cp = cp->next) { if (cp->low) { @@ -1676,7 +2060,7 @@ gfc_trans_character_select (gfc_code *code) static tree ss_string2[2], ss_string2_len[2]; static tree ss_target[2]; - cp = code->block->ext.case_list; + cp = code->block->ext.block.case_list; while (cp->left != NULL) cp = cp->left; @@ -1745,7 +2129,7 @@ gfc_trans_character_select (gfc_code *code) for (c = code->block; c; c = c->block) { - for (cp = c->ext.case_list; cp; cp = cp->next) + for (cp = c->ext.block.case_list; cp; cp = cp->next) { tree low, high; tree label; @@ -1797,8 +2181,7 @@ gfc_trans_character_select (gfc_code *code) /* Add this case label. Add parameter 'label', make it match GCC backend. */ - tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, - void_type_node, low, high, label); + tmp = build_case_label (low, high, label); gfc_add_expr_to_block (&body, tmp); } @@ -1874,14 +2257,13 @@ gfc_trans_character_select (gfc_code *code) for (c = code->block; c; c = c->block) { - for (d = c->ext.case_list; d; d = d->next) + for (d = c->ext.block.case_list; d; d = d->next) { label = gfc_build_label_decl (NULL_TREE); - tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, - void_type_node, - (d->low == NULL && d->high == NULL) - ? NULL : build_int_cst (NULL_TREE, d->n), - NULL, label); + tmp = build_case_label ((d->low == NULL && d->high == NULL) + ? NULL + : build_int_cst (integer_type_node, d->n), + NULL, label); gfc_add_expr_to_block (&body, tmp); } @@ -1934,7 +2316,7 @@ gfc_trans_character_select (gfc_code *code) } type = build_array_type (select_struct[k], - build_index_type (build_int_cst (NULL_TREE, n-1))); + build_index_type (size_int (n-1))); init = build_constructor (type, inits); TREE_CONSTANT (init) = 1; @@ -1958,7 +2340,8 @@ gfc_trans_character_select (gfc_code *code) gcc_unreachable (); tmp = build_call_expr_loc (input_location, - fndecl, 4, init, build_int_cst (NULL_TREE, n), + fndecl, 4, init, + build_int_cst (gfc_charlen_type_node, n), expr1se.expr, expr1se.string_length); case_num = gfc_create_var (integer_type_node, "case_num"); gfc_add_modify (&block, case_num, tmp); @@ -2233,8 +2616,8 @@ cleanup_forall_symtrees (gfc_code *c) { forall_restore_symtree (c->expr1); forall_restore_symtree (c->expr2); - gfc_free (new_symtree->n.sym); - gfc_free (new_symtree); + free (new_symtree->n.sym); + free (new_symtree); } @@ -2689,13 +3072,8 @@ compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, /* Walk the RHS of the expression. */ *rss = gfc_walk_expr (expr2); if (*rss == gfc_ss_terminator) - { - /* The rhs is scalar. Add a ss for the expression. */ - *rss = gfc_get_ss (); - (*rss)->next = gfc_ss_terminator; - (*rss)->type = GFC_SS_SCALAR; - (*rss)->expr = expr2; - } + /* The rhs is scalar. Add a ss for the expression. */ + *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); /* Associate the SS with the loop. */ gfc_add_ss_to_loop (&loop, *lss); @@ -2977,7 +3355,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_ss *lss, *rss; gfc_se lse; gfc_se rse; - gfc_ss_info *info; + gfc_array_info *info; gfc_loopinfo loop; tree desc; tree parm; @@ -2989,7 +3367,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, count = gfc_create_var (gfc_array_index_type, "count"); gfc_add_modify (block, count, gfc_index_zero_node); - inner_size = integer_one_node; + inner_size = gfc_index_one_node; lss = gfc_walk_expr (expr1); rss = gfc_walk_expr (expr2); if (lss == gfc_ss_terminator) @@ -3059,7 +3437,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_conv_loop_setup (&loop, &expr2->where); - info = &rss->data.info; + info = &rss->info->data.array; desc = info->descriptor; /* Make a new descriptor. */ @@ -3180,6 +3558,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) tree maskindex; tree mask; tree pmask; + tree cycle_label = NULL_TREE; int n; int nvar; int need_temp; @@ -3204,15 +3583,15 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) nvar = n; /* Allocate the space for var, start, end, step, varexpr. */ - var = (tree *) gfc_getmem (nvar * sizeof (tree)); - start = (tree *) gfc_getmem (nvar * sizeof (tree)); - end = (tree *) gfc_getmem (nvar * sizeof (tree)); - step = (tree *) gfc_getmem (nvar * sizeof (tree)); - varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *)); - saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var)); + var = XCNEWVEC (tree, nvar); + start = XCNEWVEC (tree, nvar); + end = XCNEWVEC (tree, nvar); + step = XCNEWVEC (tree, nvar); + varexpr = XCNEWVEC (gfc_expr *, nvar); + saved_vars = XCNEWVEC (gfc_saved_var, nvar); /* Allocate the space for info. */ - info = (forall_info *) gfc_getmem (sizeof (forall_info)); + info = XCNEW (forall_info); gfc_start_block (&pre); gfc_init_block (&post); @@ -3224,7 +3603,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_symbol *sym = fa->var->symtree->n.sym; /* Allocate space for this_forall. */ - this_forall = (iter_info *) gfc_getmem (sizeof (iter_info)); + this_forall = XCNEW (iter_info); /* Create a temporary variable for the FORALL index. */ tmp = gfc_typenode_for_spec (&sym->ts); @@ -3369,6 +3748,26 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_add_expr_to_block (&block, tmp); } + if (code->op == EXEC_DO_CONCURRENT) + { + gfc_init_block (&body); + cycle_label = gfc_build_label_decl (NULL_TREE); + code->cycle_label = cycle_label; + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&body, tmp); + + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (&block, tmp); + goto done; + } + c = code->block->next; /* TODO: loop merging in FORALL statements. */ @@ -3449,20 +3848,28 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) c = c->next; } +done: /* Restore the original index variables. */ for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); /* Free the space for var, start, end, step, varexpr. */ - gfc_free (var); - gfc_free (start); - gfc_free (end); - gfc_free (step); - gfc_free (varexpr); - gfc_free (saved_vars); + free (var); + free (start); + free (end); + free (step); + free (varexpr); + free (saved_vars); + + for (this_forall = info->this_loop; this_forall;) + { + iter_info *next = this_forall->next; + free (this_forall); + this_forall = next; + } /* Free the space for this forall_info. */ - gfc_free (info); + free (info); if (pmask) { @@ -3488,6 +3895,14 @@ tree gfc_trans_forall (gfc_code * code) } +/* Translate the DO CONCURRENT construct. */ + +tree gfc_trans_do_concurrent (gfc_code * code) +{ + return gfc_trans_forall_1 (code, NULL); +} + + /* Evaluate the WHERE mask expression, copy its value to a temporary. If the WHERE construct is nested in FORALL, compute the overall temporary needed by the WHERE mask expression multiplied by the iterator number of @@ -3682,7 +4097,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, /* Find a non-scalar SS from the lhs. */ while (lss_section != gfc_ss_terminator - && lss_section->type != GFC_SS_SECTION) + && lss_section->info->type != GFC_SS_SECTION) lss_section = lss_section->next; gcc_assert (lss_section != gfc_ss_terminator); @@ -3693,13 +4108,10 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, /* Walk the rhs. */ rss = gfc_walk_expr (expr2); if (rss == gfc_ss_terminator) - { - /* The rhs is scalar. Add a ss for the expression. */ - rss = gfc_get_ss (); - rss->where = 1; - rss->next = gfc_ss_terminator; - rss->type = GFC_SS_SCALAR; - rss->expr = expr2; + { + /* The rhs is scalar. Add a ss for the expression. */ + rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + rss->info->where = 1; } /* Associate the SS with the loop. */ @@ -3739,10 +4151,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, /* Translate the expression. */ gfc_conv_expr (&rse, expr2); if (lss != gfc_ss_terminator && loop.temp_ss != NULL) - { - gfc_conv_tmp_array_ref (&lse); - gfc_advance_se_ss_chain (&lse); - } + gfc_conv_tmp_array_ref (&lse); else gfc_conv_expr (&lse, expr1); @@ -3795,7 +4204,6 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, lse.ss = lss; gfc_conv_tmp_array_ref (&rse); - gfc_advance_se_ss_chain (&rse); gfc_conv_expr (&lse, expr1); gcc_assert (lse.ss == gfc_ss_terminator @@ -3923,6 +4331,9 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1, &inner_size_body, &lss, &rss); + gfc_free_ss_chain (lss); + gfc_free_ss_chain (rss); + /* Calculate the total size of temporary needed. */ size = compute_overall_iter_number (nested_forall_info, inner_size, &inner_size_body, block); @@ -4138,11 +4549,8 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) tsss = gfc_walk_expr (tsrc); if (tsss == gfc_ss_terminator) { - tsss = gfc_get_ss (); - tsss->where = 1; - tsss->next = gfc_ss_terminator; - tsss->type = GFC_SS_SCALAR; - tsss->expr = tsrc; + tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc); + tsss->info->where = 1; } gfc_add_ss_to_loop (&loop, tdss); gfc_add_ss_to_loop (&loop, tsss); @@ -4156,11 +4564,8 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) esss = gfc_walk_expr (esrc); if (esss == gfc_ss_terminator) { - esss = gfc_get_ss (); - esss->where = 1; - esss->next = gfc_ss_terminator; - esss->type = GFC_SS_SCALAR; - esss->expr = esrc; + esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc); + esss->info->where = 1; } gfc_add_ss_to_loop (&loop, edss); gfc_add_ss_to_loop (&loop, esss); @@ -4200,10 +4605,7 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) gfc_conv_expr (&tsse, tsrc); if (tdss != gfc_ss_terminator && loop.temp_ss != NULL) - { - gfc_conv_tmp_array_ref (&tdse); - gfc_advance_se_ss_chain (&tdse); - } + gfc_conv_tmp_array_ref (&tdse); else gfc_conv_expr (&tdse, tdst); @@ -4211,12 +4613,9 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) { gfc_conv_expr (&esse, esrc); if (edss != gfc_ss_terminator && loop.temp_ss != NULL) - { - gfc_conv_tmp_array_ref (&edse); - gfc_advance_se_ss_chain (&edse); - } + gfc_conv_tmp_array_ref (&edse); else - gfc_conv_expr (&edse, edst); + gfc_conv_expr (&edse, edst); } tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true); @@ -4347,63 +4746,120 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; + gfc_expr *e; gfc_expr *expr; gfc_se se; tree tmp; tree parm; tree stat; - tree pstat; - tree error_label; + tree errmsg; + tree errlen; + tree label_errmsg; + tree label_finish; tree memsz; + tree expr3; + tree slen3; stmtblock_t block; + stmtblock_t post; + gfc_expr *sz; + gfc_se se_sz; + tree class_expr; + tree nelems; + tree memsize = NULL_TREE; + tree classexpr = NULL_TREE; if (!code->ext.alloc.list) return NULL_TREE; - pstat = stat = error_label = tmp = memsz = NULL_TREE; + stat = tmp = memsz = NULL_TREE; + label_errmsg = label_finish = errmsg = errlen = NULL_TREE; - gfc_start_block (&block); + gfc_init_block (&block); + gfc_init_block (&post); - /* Either STAT= and/or ERRMSG is present. */ - if (code->expr1 || code->expr2) + /* STAT= (and maybe ERRMSG=) is present. */ + if (code->expr1) { + /* STAT=. */ tree gfc_int4_type_node = gfc_get_int_type (4); - stat = gfc_create_var (gfc_int4_type_node, "stat"); - pstat = gfc_build_addr_expr (NULL_TREE, stat); - error_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (error_label) = 1; + /* ERRMSG= only makes sense with STAT=. */ + if (code->expr2) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr_lhs (&se, code->expr2); + errmsg = se.expr; + errlen = se.string_length; + } + else + { + errmsg = null_pointer_node; + errlen = build_int_cst (gfc_charlen_type_node, 0); + } + + /* GOTO destinations. */ + label_errmsg = gfc_build_label_decl (NULL_TREE); + label_finish = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_finish) = 0; } + expr3 = NULL_TREE; + slen3 = NULL_TREE; + for (al = code->ext.alloc.list; al != NULL; al = al->next) { expr = gfc_copy_expr (al->expr); if (expr->ts.type == BT_CLASS) - gfc_add_component_ref (expr, "$data"); + gfc_add_data_component (expr); gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); se.want_pointer = 1; se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (!gfc_array_allocate (&se, expr, pstat)) + /* Evaluate expr3 just once if not a variable. */ + if (al == code->ext.alloc.list + && al->expr->ts.type == BT_CLASS + && code->expr3 + && code->expr3->ts.type == BT_CLASS + && code->expr3->expr_type != EXPR_VARIABLE) + { + gfc_init_se (&se_sz, NULL); + gfc_conv_expr_reference (&se_sz, code->expr3); + gfc_conv_class_to_class (&se_sz, code->expr3, + code->expr3->ts, false); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + gfc_add_block_to_block (&se.post, &se_sz.post); + classexpr = build_fold_indirect_ref_loc (input_location, + se_sz.expr); + classexpr = gfc_evaluate_now (classexpr, &se.pre); + memsize = gfc_vtable_size_get (classexpr); + memsize = fold_convert (sizetype, memsize); + } + + memsz = memsize; + class_expr = classexpr; + + nelems = NULL_TREE; + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, + memsz, &nelems, code->expr3)) { /* A scalar or derived type. */ /* Determine allocate size. */ - if (al->expr->ts.type == BT_CLASS && code->expr3) + if (al->expr->ts.type == BT_CLASS + && code->expr3 + && memsz == NULL_TREE) { if (code->expr3->ts.type == BT_CLASS) { - gfc_expr *sz; - gfc_se se_sz; sz = gfc_copy_expr (code->expr3); - gfc_add_component_ref (sz, "$vptr"); - gfc_add_component_ref (sz, "$size"); + gfc_add_vptr_component (sz); + gfc_add_size_component (sz); gfc_init_se (&se_sz, NULL); gfc_conv_expr (&se_sz, sz); gfc_free_expr (sz); @@ -4412,130 +4868,173 @@ gfc_trans_allocate (gfc_code * code) else memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); } + else if (al->expr->ts.type == BT_CHARACTER + && al->expr->ts.deferred && code->expr3) + { + if (!code->expr3->ts.u.cl->backend_decl) + { + /* Convert and use the length expression. */ + gfc_init_se (&se_sz, NULL); + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_CONSTANT) + { + gfc_conv_expr (&se_sz, code->expr3); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + se_sz.string_length + = gfc_evaluate_now (se_sz.string_length, &se.pre); + gfc_add_block_to_block (&se.pre, &se_sz.post); + memsz = se_sz.string_length; + } + else if (code->expr3->mold + && code->expr3->ts.u.cl + && code->expr3->ts.u.cl->length) + { + gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); + gfc_add_block_to_block (&se.pre, &se_sz.post); + memsz = se_sz.expr; + } + else + { + /* This is would be inefficient and possibly could + generate wrong code if the result were not stored + in expr3/slen3. */ + if (slen3 == NULL_TREE) + { + gfc_conv_expr (&se_sz, code->expr3); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + expr3 = gfc_evaluate_now (se_sz.expr, &se.pre); + gfc_add_block_to_block (&post, &se_sz.post); + slen3 = gfc_evaluate_now (se_sz.string_length, + &se.pre); + } + memsz = slen3; + } + } + else + /* Otherwise use the stored string length. */ + memsz = code->expr3->ts.u.cl->backend_decl; + tmp = al->expr->ts.u.cl->backend_decl; + + /* Store the string length. */ + if (tmp && TREE_CODE (tmp) == VAR_DECL) + gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), + memsz)); + + /* Convert to size in bytes, using the character KIND. */ + tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts)); + tmp = TYPE_SIZE_UNIT (tmp); + memsz = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), memsz)); + } + else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred) + { + gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); + gfc_add_block_to_block (&se.pre, &se_sz.post); + /* Store the string length. */ + tmp = al->expr->ts.u.cl->backend_decl; + gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), + se_sz.expr)); + tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); + tmp = TYPE_SIZE_UNIT (tmp); + memsz = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (se_sz.expr), + se_sz.expr)); + } else if (code->ext.alloc.ts.type != BT_UNKNOWN) memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); - else + else if (memsz == NULL_TREE) memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) - memsz = se.string_length; + { + memsz = se.string_length; + + /* Convert to size in bytes, using the character KIND. */ + tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); + tmp = TYPE_SIZE_UNIT (tmp); + memsz = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), memsz)); + } /* Allocate - for non-pointers with re-alloc checking. */ - { - gfc_ref *ref; - bool allocatable; - - ref = expr->ref; - - /* Find the last reference in the chain. */ - while (ref && ref->next != NULL) - { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); - ref = ref->next; - } - - if (!ref) - allocatable = expr->symtree->n.sym->attr.allocatable; - else - allocatable = ref->u.c.component->attr.allocatable; - - if (allocatable) - tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz, - pstat, expr); - else - tmp = gfc_allocate_with_status (&se.pre, memsz, pstat); - } - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - se.expr, - fold_convert (TREE_TYPE (se.expr), tmp)); - gfc_add_expr_to_block (&se.pre, tmp); + if (gfc_expr_attr (expr).allocatable) + gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE, + stat, errmsg, errlen, label_finish, expr); + else + gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); - if (code->expr1 || code->expr2) + if (al->expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp) { - tmp = build1_v (GOTO_EXPR, error_label); - parm = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, stat, - build_int_cst (TREE_TYPE (stat), 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - parm, tmp, - build_empty_stmt (input_location)); + tmp = build_fold_indirect_ref_loc (input_location, se.expr); + tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0); gfc_add_expr_to_block (&se.pre, tmp); } - - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + else if (al->expr->ts.type == BT_CLASS) { - tmp = build_fold_indirect_ref_loc (input_location, se.expr); - tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0); + /* With class objects, it is best to play safe and null the + memory because we cannot know if dynamic types have allocatable + components or not. */ + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMSET), + 3, se.expr, integer_zero_node, memsz); gfc_add_expr_to_block (&se.pre, tmp); } - } - tmp = gfc_finish_block (&se.pre); - gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se.pre); - if (code->expr3 && !code->expr3->mold) + /* Error checking -- Note: ERRMSG only makes sense with STAT. */ + if (code->expr1) { - /* Initialization via SOURCE block - (or static default initializer). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); - if (al->expr->ts.type == BT_CLASS) - { - gfc_se dst,src; - if (rhs->ts.type == BT_CLASS) - gfc_add_component_ref (rhs, "$data"); - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_conv_expr (&dst, expr); - gfc_conv_expr (&src, rhs); - gfc_add_block_to_block (&block, &src.pre); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); - } - else - tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), - rhs, false, false); - gfc_free_expr (rhs); - gfc_add_expr_to_block (&block, tmp); - } - else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) - { - /* Default-initialization via MOLD (polymorphic). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); - gfc_se dst,src; - gfc_add_component_ref (rhs, "$vptr"); - gfc_add_component_ref (rhs, "$def_init"); - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_conv_expr (&dst, expr); - gfc_conv_expr (&src, rhs); - gfc_add_block_to_block (&block, &src.pre); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); + tmp = build1_v (GOTO_EXPR, label_errmsg); + parm = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (parm), tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); - gfc_free_expr (rhs); } - - /* Allocation of CLASS entities. */ - gfc_free_expr (expr); - expr = al->expr; - if (expr->ts.type == BT_CLASS) + + /* We need the vptr of CLASS objects to be initialized. */ + e = gfc_copy_expr (al->expr); + if (e->ts.type == BT_CLASS) { - gfc_expr *lhs,*rhs; + gfc_expr *lhs, *rhs; gfc_se lse; - /* Initialize VPTR for CLASS objects. */ - lhs = gfc_expr_to_initialize (expr); - gfc_add_component_ref (lhs, "$vptr"); - rhs = NULL; - if (code->expr3 && code->expr3->ts.type == BT_CLASS) + lhs = gfc_expr_to_initialize (e); + gfc_add_vptr_component (lhs); + + if (class_expr != NULL_TREE) + { + /* Polymorphic SOURCE: VPTR must be determined at run time. */ + gfc_init_se (&lse, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, lhs); + tmp = gfc_class_vptr_get (class_expr); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + else if (code->expr3 && code->expr3->ts.type == BT_CLASS) { /* Polymorphic SOURCE: VPTR must be determined at run time. */ rhs = gfc_copy_expr (code->expr3); - gfc_add_component_ref (rhs, "$vptr"); + gfc_add_vptr_component (rhs); tmp = gfc_trans_pointer_assignment (lhs, rhs); gfc_add_expr_to_block (&block, tmp); gfc_free_expr (rhs); + rhs = gfc_expr_to_initialize (e); } else { @@ -4544,14 +5043,14 @@ gfc_trans_allocate (gfc_code * code) gfc_typespec *ts; if (code->expr3) ts = &code->expr3->ts; - else if (expr->ts.type == BT_DERIVED) - ts = &expr->ts; + else if (e->ts.type == BT_DERIVED) + ts = &e->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) ts = &code->ext.alloc.ts; - else if (expr->ts.type == BT_CLASS) - ts = &CLASS_DATA (expr)->ts; + else if (e->ts.type == BT_CLASS) + ts = &CLASS_DATA (e)->ts; else - ts = &expr->ts; + ts = &e->ts; if (ts->type == BT_DERIVED) { @@ -4566,35 +5065,150 @@ gfc_trans_allocate (gfc_code * code) fold_convert (TREE_TYPE (lse.expr), tmp)); } } + gfc_free_expr (lhs); + } + + gfc_free_expr (e); + + if (code->expr3 && !code->expr3->mold) + { + /* Initialization via SOURCE block + (or static default initializer). */ + gfc_expr *rhs = gfc_copy_expr (code->expr3); + if (class_expr != NULL_TREE) + { + tree to; + to = TREE_OPERAND (se.expr, 0); + + tmp = gfc_copy_class_to_class (class_expr, to, nelems); + } + else if (al->expr->ts.type == BT_CLASS) + { + gfc_actual_arglist *actual; + gfc_expr *ppc; + gfc_code *ppc_code; + gfc_ref *ref, *dataref; + + /* Do a polymorphic deep copy. */ + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (rhs); + if (rhs->ts.type == BT_CLASS) + gfc_add_data_component (actual->expr); + actual->next = gfc_get_actual_arglist (); + actual->next->expr = gfc_copy_expr (al->expr); + actual->next->expr->ts.type = BT_CLASS; + gfc_add_data_component (actual->next->expr); + + dataref = NULL; + /* Make sure we go up through the reference chain to + the _data reference, where the arrayspec is found. */ + for (ref = actual->next->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && strcmp (ref->u.c.component->name, "_data") == 0) + dataref = ref; + + if (dataref && dataref->u.c.component->as) + { + int dim; + gfc_expr *temp; + gfc_ref *ref = dataref->next; + ref->u.ar.type = AR_SECTION; + /* We have to set up the array reference to give ranges + in all dimensions and ensure that the end and stride + are set so that the copy can be scalarized. */ + dim = 0; + for (; dim < dataref->u.c.component->as->rank; dim++) + { + ref->u.ar.dimen_type[dim] = DIMEN_RANGE; + if (ref->u.ar.end[dim] == NULL) + { + ref->u.ar.end[dim] = ref->u.ar.start[dim]; + temp = gfc_get_int_expr (gfc_default_integer_kind, + &al->expr->where, 1); + ref->u.ar.start[dim] = temp; + } + temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]), + gfc_copy_expr (ref->u.ar.start[dim])); + temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind, + &al->expr->where, 1), + temp); + } + } + if (rhs->ts.type == BT_CLASS) + { + ppc = gfc_copy_expr (rhs); + gfc_add_vptr_component (ppc); + } + else + ppc = gfc_lval_expr_from_sym + (gfc_find_derived_vtab (rhs->ts.u.derived)); + gfc_add_component_ref (ppc, "_copy"); + + ppc_code = gfc_get_code (); + ppc_code->resolved_sym = ppc->symtree->n.sym; + /* Although '_copy' is set to be elemental in class.c, it is + not staying that way. Find out why, sometime.... */ + ppc_code->resolved_sym->attr.elemental = 1; + ppc_code->ext.actual = actual; + ppc_code->expr1 = ppc; + ppc_code->op = EXEC_CALL; + /* Since '_copy' is elemental, the scalarizer will take care + of arrays in gfc_trans_call. */ + tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false); + gfc_free_statements (ppc_code); + } + else if (expr3 != NULL_TREE) + { + tmp = build_fold_indirect_ref_loc (input_location, se.expr); + gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind, + slen3, expr3, code->expr3->ts.kind); + tmp = NULL_TREE; + } + else + { + /* Switch off automatic reallocation since we have just done + the ALLOCATE. */ + int realloc_lhs = gfc_option.flag_realloc_lhs; + gfc_option.flag_realloc_lhs = 0; + tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), + rhs, false, false); + gfc_option.flag_realloc_lhs = realloc_lhs; + } + gfc_free_expr (rhs); + gfc_add_expr_to_block (&block, tmp); + } + else if (code->expr3 && code->expr3->mold + && code->expr3->ts.type == BT_CLASS) + { + /* Since the _vptr has already been assigned to the allocate + object, we can use gfc_copy_class_to_class in its + initialization mode. */ + tmp = TREE_OPERAND (se.expr, 0); + tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems); + gfc_add_expr_to_block (&block, tmp); } + gfc_free_expr (expr); } - /* STAT block. */ + /* STAT. */ if (code->expr1) { - tmp = build1_v (LABEL_EXPR, error_label); + tmp = build1_v (LABEL_EXPR, label_errmsg); gfc_add_expr_to_block (&block, tmp); - - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr1); - tmp = convert (TREE_TYPE (se.expr), stat); - gfc_add_modify (&block, se.expr, tmp); } - /* ERRMSG block. */ - if (code->expr2) + /* ERRMSG - only useful if STAT is present. */ + if (code->expr1 && code->expr2) { - /* A better error message may be possible, but not required. */ const char *msg = "Attempt to allocate an allocated object"; - tree errmsg, slen, dlen; - - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr2); + tree slen, dlen, errmsg_str; + stmtblock_t errmsg_block; - errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_init_block (&errmsg_block); - gfc_add_modify (&block, errmsg, + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); @@ -4603,9 +5217,9 @@ gfc_trans_allocate (gfc_code * code) slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, slen); - dlen = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_MEMCPY], 3, - gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, + slen, errmsg_str, gfc_default_character_kind); + dlen = gfc_finish_block (&errmsg_block); tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); @@ -4615,6 +5229,24 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } + /* STAT block. */ + if (code->expr1) + { + if (TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); + gfc_add_expr_to_block (&block, tmp); + } + + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr1); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify (&block, se.expr, tmp); + } + + gfc_add_block_to_block (&block, &se.post); + gfc_add_block_to_block (&block, &post); + return gfc_finish_block (&block); } @@ -4626,37 +5258,49 @@ gfc_trans_deallocate (gfc_code *code) { gfc_se se; gfc_alloc *al; - gfc_expr *expr; - tree apstat, astat, pstat, stat, tmp; + tree apstat, pstat, stat, errmsg, errlen, tmp; + tree label_finish, label_errmsg; stmtblock_t block; - pstat = apstat = stat = astat = tmp = NULL_TREE; + pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE; + label_finish = label_errmsg = NULL_TREE; gfc_start_block (&block); /* Count the number of failed deallocations. If deallocate() was called with STAT= , then set STAT to the count. If deallocate was called with ERRMSG, then set ERRMG to a string. */ - if (code->expr1 || code->expr2) + if (code->expr1) { tree gfc_int4_type_node = gfc_get_int_type (4); stat = gfc_create_var (gfc_int4_type_node, "stat"); pstat = gfc_build_addr_expr (NULL_TREE, stat); - /* Running total of possible deallocation failures. */ - astat = gfc_create_var (gfc_int4_type_node, "astat"); - apstat = gfc_build_addr_expr (NULL_TREE, astat); + /* GOTO destinations. */ + label_errmsg = gfc_build_label_decl (NULL_TREE); + label_finish = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_finish) = 0; + } - /* Initialize astat to 0. */ - gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr_lhs (&se, code->expr2); + errmsg = se.expr; + errlen = se.string_length; } for (al = code->ext.alloc.list; al != NULL; al = al->next) { - expr = al->expr; + gfc_expr *expr = gfc_copy_expr (al->expr); gcc_assert (expr->expr_type == EXPR_VARIABLE); + if (expr->ts.type == BT_CLASS) + gfc_add_data_component (expr); + gfc_init_se (&se, NULL); gfc_start_block (&se.pre); @@ -4664,95 +5308,124 @@ gfc_trans_deallocate (gfc_code *code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) - { - gfc_ref *ref; - gfc_ref *last = NULL; - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - last = ref; - - /* Do not deallocate the components of a derived type - ultimate pointer component. */ - if (!(last && last->u.c.component->attr.pointer) - && !(!last && expr->symtree->n.sym->attr.pointer)) + if (expr->rank || gfc_is_coarray (expr)) + { + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr, - expr->rank); - gfc_add_expr_to_block (&se.pre, tmp); + gfc_ref *ref; + gfc_ref *last = NULL; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + /* Do not deallocate the components of a derived type + ultimate pointer component. */ + if (!(last && last->u.c.component->attr.pointer) + && !(!last && expr->symtree->n.sym->attr.pointer)) + { + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr, + expr->rank); + gfc_add_expr_to_block (&se.pre, tmp); + } } + tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, + label_finish, expr); + gfc_add_expr_to_block (&se.pre, tmp); } - - if (expr->rank) - tmp = gfc_array_deallocate (se.expr, pstat, expr); else { - tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr); + tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false, + expr, expr->ts); gfc_add_expr_to_block (&se.pre, tmp); + /* Set to zero after deallocation. */ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + gfc_add_expr_to_block (&se.pre, tmp); + + if (al->expr->ts.type == BT_CLASS) + { + /* Reset _vptr component to declared type. */ + gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr); + gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); + gfc_add_vptr_component (lhs); + rhs = gfc_lval_expr_from_sym (vtab); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } } - gfc_add_expr_to_block (&se.pre, tmp); - - /* Keep track of the number of failed deallocations by adding stat - of the last deallocation to the running total. */ - if (code->expr1 || code->expr2) + if (code->expr1) { - apstat = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (stat), astat, stat); - gfc_add_modify (&se.pre, astat, apstat); + tree cond; + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), + build1_v (GOTO_EXPR, label_errmsg), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, tmp); } tmp = gfc_finish_block (&se.pre); gfc_add_expr_to_block (&block, tmp); - + gfc_free_expr (expr); } - /* Set STAT. */ if (code->expr1) { - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr1); - tmp = convert (TREE_TYPE (se.expr), astat); - gfc_add_modify (&block, se.expr, tmp); + tmp = build1_v (LABEL_EXPR, label_errmsg); + gfc_add_expr_to_block (&block, tmp); } - /* Set ERRMSG. */ - if (code->expr2) + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) { - /* A better error message may be possible, but not required. */ const char *msg = "Attempt to deallocate an unallocated object"; - tree errmsg, slen, dlen; - - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr2); + stmtblock_t errmsg_block; + tree errmsg_str, slen, dlen, cond; - errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_init_block (&errmsg_block); - gfc_add_modify (&block, errmsg, + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (msg))); - slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); dlen = gfc_get_expr_charlen (code->expr2); - slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, - slen); - dlen = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_MEMCPY], 3, - gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, + slen, errmsg_str, gfc_default_character_kind); + tmp = gfc_finish_block (&errmsg_block); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat, - build_int_cst (TREE_TYPE (astat), 0)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond), tmp, + build_empty_stmt (input_location)); - tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + if (code->expr1 && TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); gfc_add_expr_to_block (&block, tmp); } + /* Set STAT. */ + if (code->expr1) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr1); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify (&block, se.expr, tmp); + } + return gfc_finish_block (&block); }