X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-stmt.c;h=edffb9bfd8f5e7564cce52906746113292947f71;hp=1a1352de8ddf2a5ee47c84eaf3050db5e0434c7a;hb=de190a06650b084bfe339e490457f14e522a7dbb;hpb=578d3f19254285122766e8003a4fce1c7376d6ba diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1a1352de8dd..edffb9bfd8f 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1,5 +1,5 @@ /* Statement translation -- generate GCC trees from gfc_code. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -159,31 +159,15 @@ gfc_trans_goto (gfc_code * code) assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); - code = code->block; - if (code == NULL) - { - target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto); - gfc_add_expr_to_block (&se.pre, target); - return gfc_finish_block (&se.pre); - } - - /* Check the label list. */ - do - { - target = gfc_get_label_decl (code->label1); - tmp = gfc_build_addr_expr (pvoid_type_node, target); - tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto); - tmp = build3_v (COND_EXPR, tmp, - fold_build1 (GOTO_EXPR, void_type_node, target), - build_empty_stmt ()); - gfc_add_expr_to_block (&se.pre, tmp); - code = code->block; - } - while (code != NULL); - gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc, - "Assigned label is not in the list"); + /* We're going to ignore a label list. It does not really change the + statement's semantics (because it is just a further restriction on + what's legal code); before, we were comparing label addresses here, but + that's a very fragile business and may break with optimization. So + just ignore it. */ - return gfc_finish_block (&se.pre); + target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto); + gfc_add_expr_to_block (&se.pre, target); + return gfc_finish_block (&se.pre); } @@ -212,6 +196,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, gfc_ss *ss; gfc_ss_info *info; gfc_symbol *fsym; + gfc_ref *ref; int n; tree data; tree offset; @@ -267,6 +252,34 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, /* 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); @@ -309,18 +322,19 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, offset = gfc_index_zero_node; for (n = 0; n < info->dimen; n++) { - tmp = gfc_conv_descriptor_stride (info->descriptor, - gfc_rank_cst[n]); + tmp = gfc_conv_descriptor_stride_get (info->descriptor, + gfc_rank_cst[n]); tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, loopse->loop->from[n], tmp); offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, - offset, tmp); + offset, tmp); } 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 (gfor_fndecl_in_unpack, 2, parmse.expr, data); + 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. */ @@ -453,7 +467,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, if (mask && count1) { tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, - build_empty_stmt ()); + build_empty_stmt (input_location)); gfc_add_expr_to_block (&loopse.pre, tmp); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, count1, gfc_index_one_node); @@ -539,12 +553,14 @@ gfc_trans_pause (gfc_code * code) if (code->expr1 == NULL) { tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); - tmp = build_call_expr (gfor_fndecl_pause_numeric, 1, tmp); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_pause_numeric, 1, tmp); } else { gfc_conv_expr_reference (&se, code->expr1); - tmp = build_call_expr (gfor_fndecl_pause_string, 2, + tmp = build_call_expr_loc (input_location, + gfor_fndecl_pause_string, 2, se.expr, se.string_length); } @@ -560,7 +576,7 @@ gfc_trans_pause (gfc_code * code) to a runtime library call. */ tree -gfc_trans_stop (gfc_code * code) +gfc_trans_stop (gfc_code *code, bool error_stop) { tree gfc_int4_type_node = gfc_get_int_type (4); gfc_se se; @@ -570,17 +586,19 @@ gfc_trans_stop (gfc_code * code) gfc_init_se (&se, NULL); gfc_start_block (&se.pre); - if (code->expr1 == NULL) { tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); - tmp = build_call_expr (gfor_fndecl_stop_numeric, 1, tmp); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_stop_numeric, 1, tmp); } else { gfc_conv_expr_reference (&se, code->expr1); - tmp = build_call_expr (gfor_fndecl_stop_string, 2, - se.expr, se.string_length); + tmp = build_call_expr_loc (input_location, + error_stop ? gfor_fndecl_error_stop_string + : gfor_fndecl_stop_string, + 2, se.expr, se.string_length); } gfc_add_expr_to_block (&se.pre, tmp); @@ -591,6 +609,47 @@ gfc_trans_stop (gfc_code * code) } +tree +gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) +{ + gfc_se se; + + if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) + { + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + } + + /* Check SYNC IMAGES(imageset) for valid image index. + FIXME: Add a check for image-set arrays. */ + if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && code->expr1->rank == 0) + { + tree cond; + gfc_conv_expr (&se, code->expr1); + cond = fold_build2 (NE_EXPR, boolean_type_node, se.expr, + build_int_cst (TREE_TYPE (se.expr), 1)); + 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) + { + 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)); + } + + if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) + return gfc_finish_block (&se.pre); + + return NULL_TREE; +} + + /* Generate GENERIC for the IF construct. This function also deals with the simple IF statement, because the front end translates the IF statement into an IF construct. @@ -655,7 +714,7 @@ gfc_trans_if_1 (gfc_code * code) if (code->block) elsestmt = gfc_trans_if_1 (code->block); else - elsestmt = build_empty_stmt (); + elsestmt = build_empty_stmt (input_location); /* Build the condition expression and add it to the condition block. */ stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt); @@ -751,6 +810,51 @@ gfc_trans_arithmetic_if (gfc_code * code) } +/* Translate a CRITICAL block. */ +tree +gfc_trans_critical (gfc_code *code) +{ + stmtblock_t block; + tree tmp; + + gfc_start_block (&block); + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate a BLOCK construct. This is basically what we would do for a + procedure body. */ + +tree +gfc_trans_block_construct (gfc_code* code) +{ + gfc_namespace* ns; + gfc_symbol* sym; + stmtblock_t body; + tree tmp; + + ns = code->ext.ns; + gcc_assert (ns); + sym = ns->proc_name; + gcc_assert (sym); + + gcc_assert (!sym->tlink); + sym->tlink = sym; + + gfc_start_block (&body); + gfc_process_block_locals (ns); + + tmp = gfc_trans_code (ns->code); + tmp = gfc_trans_deferred_vars (sym, tmp); + + gfc_add_expr_to_block (&body, tmp); + return gfc_finish_block (&body); +} + + /* Translate the simple DO construct. This is where the loop variable has integer type and step +-1. We can't use this in the general case because integer overflow and floating point errors could give incorrect @@ -783,7 +887,7 @@ gfc_trans_arithmetic_if (gfc_code * code) static tree gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, - tree from, tree to, tree step) + tree from, tree to, tree step, tree exit_cond) { stmtblock_t body; tree type; @@ -816,7 +920,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, gfc_start_block (&body); /* Main loop body. */ - tmp = gfc_trans_code (code->block->next); + tmp = gfc_trans_code_cond (code->block->next, exit_cond); gfc_add_expr_to_block (&body, tmp); /* Label for cycle statements (if needed). */ @@ -834,6 +938,15 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, "Loop variable has been modified"); } + /* Exit the loop if there is an I/O result condition or error. */ + if (exit_cond) + { + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3 (COND_EXPR, void_type_node, exit_cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + } + /* Evaluate the loop condition. */ cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to); cond = gfc_evaluate_now (cond, &body); @@ -849,7 +962,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt ()); + cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); /* Finish the loop body. */ @@ -862,7 +975,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, else cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to); tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt ()); + cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (pblock, tmp); /* Add the exit label. */ @@ -907,7 +1020,7 @@ exit_label: because the loop count itself can overflow. */ tree -gfc_trans_do (gfc_code * code) +gfc_trans_do (gfc_code * code, tree exit_cond) { gfc_se se; tree dovar; @@ -962,7 +1075,7 @@ gfc_trans_do (gfc_code * code) if (TREE_CODE (type) == INTEGER_TYPE && (integer_onep (step) || tree_int_cst_equal (step, integer_minus_one_node))) - return gfc_trans_simple_do (code, &block, dovar, from, to, step); + return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond); pos_step = fold_build2 (GT_EXPR, boolean_type_node, step, fold_convert (type, integer_zero_node)); @@ -990,44 +1103,57 @@ gfc_trans_do (gfc_code * code) /* Initialize loop count and jump to exit label if the loop is empty. This code is executed before we enter the loop body. We generate: + step_sign = sign(1,step); if (step > 0) { - if (to < from) goto exit_label; - countm1 = (to - from) / step; + if (to < from) + goto exit_label; } else { - if (to > from) goto exit_label; - countm1 = (from - to) / -step; - } */ + if (to > from) + goto exit_label; + } + countm1 = (to*step_sign - from*step_sign) / (step*step_sign); + + */ + if (TREE_CODE (type) == INTEGER_TYPE) { - tree pos, neg; + tree pos, neg, step_sign, to2, from2, step2; + + /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */ + + tmp = fold_build2 (LT_EXPR, boolean_type_node, step, + build_int_cst (TREE_TYPE (step), 0)); + step_sign = fold_build3 (COND_EXPR, type, tmp, + build_int_cst (type, -1), + build_int_cst (type, 1)); tmp = fold_build2 (LT_EXPR, boolean_type_node, to, from); pos = fold_build3 (COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), - build_empty_stmt ()); - tmp = fold_build2 (MINUS_EXPR, type, to, from); - tmp = fold_convert (utype, tmp); - tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, - fold_convert (utype, step)); - tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp); - pos = build2 (COMPOUND_EXPR, void_type_node, pos, tmp); + build_empty_stmt (input_location)); tmp = fold_build2 (GT_EXPR, boolean_type_node, to, from); neg = fold_build3 (COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), - build_empty_stmt ()); - tmp = fold_build2 (MINUS_EXPR, type, from, to); - tmp = fold_convert (utype, tmp); - tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, - fold_convert (utype, fold_build1 (NEGATE_EXPR, - type, step))); - tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp); - neg = build2 (COMPOUND_EXPR, void_type_node, neg, tmp); - + build_empty_stmt (input_location)); tmp = fold_build3 (COND_EXPR, void_type_node, pos_step, pos, neg); + + gfc_add_expr_to_block (&block, tmp); + + /* Calculate the loop count. to-from can overflow, so + we cast to unsigned. */ + + to2 = fold_build2 (MULT_EXPR, type, step_sign, to); + from2 = fold_build2 (MULT_EXPR, type, step_sign, from); + step2 = fold_build2 (MULT_EXPR, type, step_sign, step); + step2 = fold_convert (utype, step2); + tmp = fold_build2 (MINUS_EXPR, type, to2, from2); + tmp = fold_convert (utype, tmp); + tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, step2); + tmp = fold_build2 (MODIFY_EXPR, void_type_node, countm1, tmp); gfc_add_expr_to_block (&block, tmp); } else @@ -1049,7 +1175,7 @@ gfc_trans_do (gfc_code * code) /* If the loop is empty, go directly to the exit label. */ tmp = fold_build3 (COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), - build_empty_stmt ()); + build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } @@ -1064,7 +1190,7 @@ gfc_trans_do (gfc_code * code) code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); /* Main loop body. */ - tmp = gfc_trans_code (code->block->next); + tmp = gfc_trans_code_cond (code->block->next, exit_cond); gfc_add_expr_to_block (&body, tmp); /* Label for cycle statements (if needed). */ @@ -1082,6 +1208,15 @@ gfc_trans_do (gfc_code * code) "Loop variable has been modified"); } + /* Exit the loop if there is an I/O result condition or error. */ + if (exit_cond) + { + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3 (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 (PLUS_EXPR, type, dovar, step); gfc_add_modify (&body, dovar, tmp); @@ -1094,7 +1229,7 @@ gfc_trans_do (gfc_code * code) build_int_cst (utype, 0)); tmp = build1_v (GOTO_EXPR, exit_label); tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt ()); + cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); /* Decrement the loop count. */ @@ -1168,7 +1303,7 @@ gfc_trans_do_while (gfc_code * code) tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = fold_build3 (COND_EXPR, void_type_node, - cond.expr, tmp, build_empty_stmt ()); + cond.expr, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); /* The main body of the loop. */ @@ -1413,8 +1548,8 @@ gfc_trans_logical_select (gfc_code * code) { tree true_tree, false_tree, stmt; - true_tree = build_empty_stmt (); - false_tree = build_empty_stmt (); + true_tree = build_empty_stmt (input_location); + false_tree = build_empty_stmt (input_location); /* If we have a case for .TRUE. and for .FALSE., discard the default case. Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, @@ -1614,7 +1749,8 @@ gfc_trans_character_select (gfc_code *code) else gcc_unreachable (); - tmp = build_call_expr (fndecl, 4, init, build_int_cst (NULL_TREE, n), + tmp = build_call_expr_loc (input_location, + fndecl, 4, init, build_int_cst (NULL_TREE, n), se.expr, se.string_length); case_num = gfc_create_var (integer_type_node, "case_num"); gfc_add_modify (&block, case_num, tmp); @@ -1653,7 +1789,7 @@ gfc_trans_select (gfc_code * code) /* Empty SELECT constructs are legal. */ if (code->block == NULL) - return build_empty_stmt (); + return build_empty_stmt (input_location); /* Select the correct translation function. */ switch (code->expr1->ts.type) @@ -1738,17 +1874,16 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) if (old_sym->attr.dimension) { gfc_init_se (&tse, NULL); - gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN); + gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false); gfc_add_block_to_block (pre, &tse.pre); gfc_add_block_to_block (post, &tse.post); - tse.expr = build_fold_indirect_ref (tse.expr); + tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr); if (e->ts.type != BT_CHARACTER) { /* Use the variable offset for the temporary. */ - tmp = gfc_conv_descriptor_offset (tse.expr); - gfc_add_modify (pre, tmp, - gfc_conv_array_offset (old_sym->backend_decl)); + tmp = gfc_conv_array_offset (old_sym->backend_decl); + gfc_conv_descriptor_offset_set (pre, tse.expr, tmp); } } else @@ -1773,7 +1908,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) } tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true, - e->expr_type == EXPR_VARIABLE); + e->expr_type == EXPR_VARIABLE, true); gfc_add_expr_to_block (pre, tmp); } gfc_free_expr (e); @@ -1825,7 +1960,7 @@ check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) pointer components. We therefore leave these to their own devices. */ if (lsym->ts.type == BT_DERIVED - && lsym->ts.derived->attr.pointer_comp) + && lsym->ts.u.derived->attr.pointer_comp) return need_temp; new_symtree = NULL; @@ -1929,7 +2064,7 @@ gfc_trans_forall_loop (forall_info *forall_tmp, tree body, count, build_int_cst (TREE_TYPE (count), 0)); tmp = build1_v (GOTO_EXPR, exit_label); tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt ()); + cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); /* The main loop body. */ @@ -2011,7 +2146,8 @@ gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, if (mask) { tmp = gfc_build_array_ref (mask, maskindex, NULL); - body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ()); + body = build3_v (COND_EXPR, tmp, body, + build_empty_stmt (input_location)); } } body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header); @@ -2136,7 +2272,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, /* Use the scalar assignment. */ rse.string_length = lse.string_length; - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true); /* Form the mask expression according to the mask tree list. */ if (wheremask) @@ -2147,7 +2283,8 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, TREE_TYPE (wheremaskexpr), wheremaskexpr); tmp = fold_build3 (COND_EXPR, void_type_node, - wheremaskexpr, tmp, build_empty_stmt ()); + wheremaskexpr, tmp, + build_empty_stmt (input_location)); } gfc_add_expr_to_block (&body, tmp); @@ -2233,7 +2370,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, /* Use the scalar assignment. */ lse.string_length = rse.string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true, - expr2->expr_type == EXPR_VARIABLE); + expr2->expr_type == EXPR_VARIABLE, true); /* Form the mask expression according to the mask tree list. */ if (wheremask) @@ -2244,7 +2381,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, TREE_TYPE (wheremaskexpr), wheremaskexpr); tmp = fold_build3 (COND_EXPR, void_type_node, - wheremaskexpr, tmp, build_empty_stmt ()); + wheremaskexpr, tmp, build_empty_stmt (input_location)); } gfc_add_expr_to_block (&body1, tmp); @@ -2440,7 +2577,7 @@ allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type); if (*ptemp1) - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, tmp); return tmp; } @@ -2532,17 +2669,17 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, &lss, &rss); /* The type of LHS. Used in function allocate_temp_for_forall_nest */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length) + if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length) { - if (!expr1->ts.cl->backend_decl) + if (!expr1->ts.u.cl->backend_decl) { gfc_se tse; gfc_init_se (&tse, NULL); - gfc_conv_expr (&tse, expr1->ts.cl->length); - expr1->ts.cl->backend_decl = tse.expr; + gfc_conv_expr (&tse, expr1->ts.u.cl->length); + expr1->ts.u.cl->backend_decl = tse.expr; } type = gfc_get_character_type_len (gfc_default_character_kind, - expr1->ts.cl->backend_decl); + expr1->ts.u.cl->backend_decl); } else type = gfc_typenode_for_spec (&expr1->ts); @@ -2685,9 +2822,9 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, /* Make a new descriptor. */ parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, loop.from, loop.to, 1, - GFC_ARRAY_UNKNOWN); + GFC_ARRAY_UNKNOWN, true); /* Allocate temporary for nested forall construct. */ tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, @@ -2816,7 +2953,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) if (code->expr1 && code->expr1->expr_type == EXPR_CONSTANT && !code->expr1->value.logical) - return build_empty_stmt (); + return build_empty_stmt (input_location); n = 0; /* Count the FORALL index number. */ @@ -3010,7 +3147,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) else { /* Use the normal assignment copying routines. */ - assign = gfc_trans_assignment (c->expr1, c->expr2, false); + assign = gfc_trans_assignment (c->expr1, c->expr2, false, true); /* Generate body and loops. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, @@ -3371,9 +3508,9 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, /* Use the scalar assignment as is. */ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - loop.temp_ss != NULL, false); + loop.temp_ss != NULL, false, true); - tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); @@ -3425,8 +3562,10 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, maskexpr); /* Use the scalar assignment as is. */ - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false); - tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false, + true); + tmp = build3_v (COND_EXPR, maskexpr, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); /* Increment count2. */ @@ -3831,9 +3970,10 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) gfc_conv_expr (&edse, edst); } - tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false); - estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false) - : build_empty_stmt (); + tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true); + estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, + false, true) + : build_empty_stmt (input_location); tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); gfc_add_expr_to_block (&body, tmp); gfc_add_block_to_block (&body, &cse.post); @@ -3961,12 +4101,13 @@ gfc_trans_allocate (gfc_code * code) tree stat; tree pstat; tree error_label; + tree memsz; stmtblock_t block; - if (!code->ext.alloc_list) + if (!code->ext.alloc.list) return NULL_TREE; - pstat = stat = error_label = tmp = NULL_TREE; + pstat = stat = error_label = tmp = memsz = NULL_TREE; gfc_start_block (&block); @@ -3982,9 +4123,12 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (error_label) = 1; } - for (al = code->ext.alloc_list; al != NULL; al = al->next) + for (al = code->ext.alloc.list; al != NULL; al = al->next) { - expr = al->expr; + expr = gfc_copy_expr (al->expr); + + if (expr->ts.type == BT_CLASS) + gfc_add_component_ref (expr, "$data"); gfc_init_se (&se, NULL); gfc_start_block (&se.pre); @@ -3996,12 +4140,56 @@ gfc_trans_allocate (gfc_code * code) if (!gfc_array_allocate (&se, expr, pstat)) { /* A scalar or derived type. */ - tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); - if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE) - tmp = se.string_length; + /* Determine allocate size. */ + if (code->expr3 && 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_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + memsz = se_sz.expr; + } + else if (code->expr3 && code->expr3->ts.type != BT_CLASS) + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); + else + memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + + if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) + memsz = se.string_length; + + /* 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 = gfc_allocate_with_status (&se.pre, tmp, pstat); tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr, fold_convert (TREE_TYPE (se.expr), tmp)); gfc_add_expr_to_block (&se.pre, tmp); @@ -4012,14 +4200,14 @@ gfc_trans_allocate (gfc_code * code) parm = fold_build2 (NE_EXPR, boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = fold_build3 (COND_EXPR, void_type_node, - parm, tmp, build_empty_stmt ()); + parm, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se.pre, tmp); } - if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { - tmp = build_fold_indirect_ref (se.expr); - tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0); + 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); } @@ -4027,6 +4215,82 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_finish_block (&se.pre); gfc_add_expr_to_block (&block, tmp); + + /* Initialization via SOURCE block. */ + if (code->expr3) + { + 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); + } + + /* Allocation of CLASS entities. */ + gfc_free_expr (expr); + expr = al->expr; + if (expr->ts.type == BT_CLASS) + { + 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) + { + /* VPTR must be determined at run time. */ + rhs = gfc_copy_expr (code->expr3); + gfc_add_component_ref (rhs, "$vptr"); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (rhs); + } + else + { + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + gfc_typespec *ts; + if (code->expr3) + ts = &code->expr3->ts; + else if (expr->ts.type == BT_DERIVED) + ts = &expr->ts; + else if (code->ext.alloc.ts.type == BT_DERIVED) + ts = &code->ext.alloc.ts; + else if (expr->ts.type == BT_CLASS) + ts = &expr->ts.u.derived->components->ts; + else + ts = &expr->ts; + + if (ts->type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + gfc_init_se (&lse, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, lhs); + tmp = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + } + } + } /* STAT block. */ @@ -4061,13 +4325,14 @@ gfc_trans_allocate (gfc_code * code) dlen = gfc_get_expr_charlen (code->expr2); slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen); - dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, + 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); tmp = fold_build2 (NE_EXPR, boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); - tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } @@ -4109,7 +4374,7 @@ gfc_trans_deallocate (gfc_code *code) gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); } - for (al = code->ext.alloc_list; al != NULL; al = al->next) + for (al = code->ext.alloc.list; al != NULL; al = al->next) { expr = al->expr; gcc_assert (expr->expr_type == EXPR_VARIABLE); @@ -4121,7 +4386,7 @@ gfc_trans_deallocate (gfc_code *code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { gfc_ref *ref; gfc_ref *last = NULL; @@ -4134,7 +4399,7 @@ gfc_trans_deallocate (gfc_code *code) if (!(last && last->u.c.component->attr.pointer) && !(!last && expr->symtree->n.sym->attr.pointer)) { - tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr, + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr, expr->rank); gfc_add_expr_to_block (&se.pre, tmp); } @@ -4195,13 +4460,14 @@ gfc_trans_deallocate (gfc_code *code) dlen = gfc_get_expr_charlen (code->expr2); slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen); - dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, + 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); tmp = fold_build2 (NE_EXPR, boolean_type_node, astat, build_int_cst (TREE_TYPE (astat), 0)); - tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); }