From 60f5ed26b3f6935f26df139c7be127024eedd2c5 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 26 Oct 2009 10:08:03 +0100 Subject: [PATCH] re PR fortran/41714 ([OOP] ALLOCATE SOURCE= does not properly copy the value from SOURCE) 2009-10-26 Janus Weil PR fortran/41714 * gimple.h (tree_annotate_all_with_location): Remove prototype. * gimplify.c (tree_should_carry_location_p, tree_annotate_one_with_location,tree_annotate_all_with_location): Remove obsolete functions. 2009-10-26 Janus Weil PR fortran/41714 * trans.c (gfc_trans_code): Remove call to 'tree_annotate_all_with_location'. Location should already be set. * trans-openmp.c (gfc_trans_omp_workshare): Ditto. * trans-stmt.c (gfc_trans_allocate): Do correct data initialization for CLASS variables with SOURCE tag, plus some cleanup. 2009-10-26 Janus Weil PR fortran/41714 * gfortran.dg/class_allocate_4.f03: New test. From-SVN: r153547 --- gcc/ChangeLog | 8 +++ gcc/fortran/ChangeLog | 9 +++ gcc/fortran/trans-openmp.c | 5 -- gcc/fortran/trans-stmt.c | 70 ++++++------------- gcc/fortran/trans.c | 4 +- gcc/gimple.h | 1 - gcc/gimplify.c | 50 ------------- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/class_allocate_4.f03 | 23 ++++++ 9 files changed, 67 insertions(+), 108 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_4.f03 diff --git a/gcc/ChangeLog b/gcc/ChangeLog index a9a16933e03..4ce99eb4e96 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,11 @@ +2009-10-26 Janus Weil + + PR fortran/41714 + * gimple.h (tree_annotate_all_with_location): Remove prototype. + * gimplify.c (tree_should_carry_location_p, + tree_annotate_one_with_location,tree_annotate_all_with_location): + Remove obsolete functions. + 2009-10-25 Kaz Kojima PR target/41813 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c97733c7c4f..8c333d8ca18 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2009-10-26 Janus Weil + + PR fortran/41714 + * trans.c (gfc_trans_code): Remove call to + 'tree_annotate_all_with_location'. Location should already be set. + * trans-openmp.c (gfc_trans_omp_workshare): Ditto. + * trans-stmt.c (gfc_trans_allocate): Do correct data initialization for + CLASS variables with SOURCE tag, plus some cleanup. + 2009-10-24 Janus Weil Paul Thomas diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 56534ccdd38..4d461cfa488 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1641,11 +1641,6 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) { - if (TREE_CODE (res) == STATEMENT_LIST) - tree_annotate_all_with_location (&res, input_location); - else - SET_EXPR_LOCATION (res, input_location); - if (prev_singleunit) { if (ompws_flags & OMPWS_CURR_SINGLEUNIT) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7dc7405c67f..9b2a6230853 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3983,12 +3983,13 @@ gfc_trans_allocate (gfc_code * code) tree stat; tree pstat; tree error_label; + tree memsz; stmtblock_t block; 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); @@ -4032,19 +4033,19 @@ gfc_trans_allocate (gfc_code * code) gfc_init_se (&se_sz, NULL); gfc_conv_expr (&se_sz, sz); gfc_free_expr (sz); - tmp = se_sz.expr; + memsz = se_sz.expr; } else if (code->expr3 && code->expr3->ts.type != BT_CLASS) - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); else if (code->ext.alloc.ts.type != BT_UNKNOWN) - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); else - tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); - if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE) - tmp = se.string_length; + if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) + memsz = se.string_length; - tmp = gfc_allocate_with_status (&se.pre, tmp, pstat); + tmp = gfc_allocate_with_status (&se.pre, memsz, 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); @@ -4075,21 +4076,17 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3) { gfc_expr *rhs = gfc_copy_expr (code->expr3); - if (rhs->ts.type == BT_CLASS) + if (al->expr->ts.type == BT_CLASS) { - gfc_se dst,src,len; - gfc_expr *sz; - gfc_add_component_ref (rhs, "$data"); - sz = gfc_copy_expr (code->expr3); - gfc_add_component_ref (sz, "$size"); + 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_init_se (&len, NULL); gfc_conv_expr (&dst, expr); gfc_conv_expr (&src, rhs); - gfc_conv_expr (&len, sz); - gfc_free_expr (sz); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, len.expr); + 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), @@ -4108,8 +4105,7 @@ gfc_trans_allocate (gfc_code * code) gfc_conv_expr (&dst, expr); gfc_conv_expr (&src, init_e); gfc_add_block_to_block (&block, &src.pre); - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, tmp); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); gfc_add_expr_to_block (&block, tmp); } /* Add default initializer for those derived types that need them. */ @@ -4127,6 +4123,7 @@ gfc_trans_allocate (gfc_code * code) if (expr->ts.type == BT_CLASS) { gfc_expr *lhs,*rhs; + gfc_se lse; /* Initialize VINDEX for CLASS objects. */ lhs = gfc_expr_to_initialize (expr); gfc_add_component_ref (lhs, "$vindex"); @@ -4158,36 +4155,11 @@ gfc_trans_allocate (gfc_code * code) /* Initialize SIZE for CLASS objects. */ lhs = gfc_expr_to_initialize (expr); gfc_add_component_ref (lhs, "$size"); - rhs = NULL; - if (code->expr3 && code->expr3->ts.type == BT_CLASS) - { - /* Size must be determined at run time. */ - rhs = gfc_copy_expr (code->expr3); - gfc_add_component_ref (rhs, "$size"); - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_add_expr_to_block (&block, tmp); - } - else - { - /* Size is fixed at compile time. */ - gfc_typespec *ts; - gfc_se lse; - gfc_init_se (&lse, NULL); - gfc_conv_expr (&lse, lhs); - if (code->expr3) - ts = &code->expr3->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; - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts)); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); - } + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, lhs); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), memsz)); gfc_free_expr (lhs); - gfc_free_expr (rhs); } } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 22c3e076085..42d22388105 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1281,9 +1281,7 @@ gfc_trans_code (gfc_code * code) if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) { - if (TREE_CODE (res) == STATEMENT_LIST) - tree_annotate_all_with_location (&res, input_location); - else + if (TREE_CODE (res) != STATEMENT_LIST) SET_EXPR_LOCATION (res, input_location); /* Add the new statement to the block. */ diff --git a/gcc/gimple.h b/gcc/gimple.h index 87309b694d4..8f6b3522098 100644 --- a/gcc/gimple.h +++ b/gcc/gimple.h @@ -939,7 +939,6 @@ extern tree create_tmp_var (tree, const char *); extern tree get_initialized_tmp_var (tree, gimple_seq *, gimple_seq *); extern tree get_formal_tmp_var (tree, gimple_seq *); extern void declare_vars (tree, gimple, bool); -extern void tree_annotate_all_with_location (tree *, location_t); extern void annotate_all_with_location (gimple_seq, location_t); /* Validation of GIMPLE expressions. Note that these predicates only check diff --git a/gcc/gimplify.c b/gcc/gimplify.c index c0cab205613..d68aacd04f3 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -777,23 +777,6 @@ should_carry_location_p (gimple gs) return true; } -/* Same, but for a tree. */ - -static bool -tree_should_carry_location_p (const_tree stmt) -{ - /* Don't emit a line note for a label. We particularly don't want to - emit one for the break label, since it doesn't actually correspond - to the beginning of the loop/switch. */ - if (TREE_CODE (stmt) == LABEL_EXPR) - return false; - - /* Do not annotate empty statements, since it confuses gcov. */ - if (!TREE_SIDE_EFFECTS (stmt)) - return false; - - return true; -} /* Return true if a location should not be emitted for this statement by annotate_one_with_location. */ @@ -826,16 +809,6 @@ annotate_one_with_location (gimple gs, location_t location) gimple_set_location (gs, location); } -/* Same, but for tree T. */ - -static void -tree_annotate_one_with_location (tree t, location_t location) -{ - if (CAN_HAVE_LOCATION_P (t) - && ! EXPR_HAS_LOCATION (t) && tree_should_carry_location_p (t)) - SET_EXPR_LOCATION (t, location); -} - /* Set LOCATION for all the statements after iterator GSI in sequence SEQ. If GSI is pointing to the end of the sequence, start with the @@ -872,29 +845,6 @@ annotate_all_with_location (gimple_seq stmt_p, location_t location) } } -/* Same, but for statement or statement list in *STMT_P. */ - -void -tree_annotate_all_with_location (tree *stmt_p, location_t location) -{ - tree_stmt_iterator i; - - if (!*stmt_p) - return; - - for (i = tsi_start (*stmt_p); !tsi_end_p (i); tsi_next (&i)) - { - tree t = tsi_stmt (i); - - /* Assuming we've already been gimplified, we shouldn't - see nested chaining constructs anymore. */ - gcc_assert (TREE_CODE (t) != STATEMENT_LIST - && TREE_CODE (t) != COMPOUND_EXPR); - - tree_annotate_one_with_location (t, location); - } -} - /* Similar to copy_tree_r() but do not copy SAVE_EXPR or TARGET_EXPR nodes. These nodes model computations that should only be done once. If we diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e497e3d9fce..db1124b57da 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-10-26 Janus Weil + + PR fortran/41714 + * gfortran.dg/class_allocate_4.f03: New test. + 2009-10-24 Adam Nemet * gcc.target/mips/mult-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/class_allocate_4.f03 b/gcc/testsuite/gfortran.dg/class_allocate_4.f03 new file mode 100644 index 00000000000..d1ebf8cc915 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_4.f03 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! PR 41714: [OOP] ALLOCATE SOURCE= does not properly copy the value from SOURCE +! +! Contributed by Tobias Burnus + +type t + integer :: i +end type t +type, extends(t) :: t2 + integer :: j +end type t2 + +class(t), allocatable :: a +allocate(a, source=t2(1,2)) +print *,a%i +if(a%i /= 1) call abort() +select type (a) + type is (t2) + print *,a%j + if(a%j /= 2) call abort() +end select +end