From: Andre Vehreschild Date: Thu, 13 Oct 2016 08:51:21 +0000 (+0200) Subject: re PR fortran/72832 ([OOP] ALLOCATE with SOURCE fails to allocate requested dimensions) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=92c5266bbd5378a5513f43edf23b1394621675a3;p=gcc.git re PR fortran/72832 ([OOP] ALLOCATE with SOURCE fails to allocate requested dimensions) gcc/fortran/ChangeLog: 2016-09-01 Andre Vehreschild PR fortran/72832 * trans-expr.c (gfc_copy_class_to_class): Add generation of runtime array bounds check. * trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to get the descriptor of a function returning a class object. * trans-stmt.c (gfc_trans_allocate): Use the array spec on the array to allocate instead of the array spec from source=. gcc/testsuite/ChangeLog: 2016-09-01 Andre Vehreschild PR fortran/72832 * gfortran.dg/allocate_with_source_22.f03: New test. * gfortran.dg/allocate_with_source_23.f03: New test. Expected to fail. From-SVN: r241088 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 437e53b84bd..899e15ecf1f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2016-10-13 Andre Vehreschild + + PR fortran/72832 + * trans-expr.c (gfc_copy_class_to_class): Add generation of + runtime array bounds check. + * trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to + get the descriptor of a function returning a class object. + * trans-stmt.c (gfc_trans_allocate): Use the array spec on the + array to allocate instead of the array spec from source=. + 2016-10-12 Andre Vehreschild * trans-expr.c (gfc_find_and_cut_at_last_class_ref): Fixed style. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 655399b2ec9..6b974db5e7f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1235,6 +1235,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) stmtblock_t body; stmtblock_t ifbody; gfc_loopinfo loop; + tree orig_nelems = nelems; /* Needed for bounds check. */ gfc_init_block (&body); tmp = fold_build2_loc (input_location, MINUS_EXPR, @@ -1262,6 +1263,31 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) } vec_safe_push (args, to_ref); + /* Add bounds check. */ + if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc) + { + char *msg; + const char *name = "<>"; + tree from_len; + + if (DECL_P (to)) + name = (const char *)(DECL_NAME (to)->identifier.id.str); + + from_len = gfc_conv_descriptor_size (from_data, 1); + tmp = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, from_len, orig_nelems); + msg = xasprintf ("Array bound mismatch for dimension %d " + "of array '%s' (%%ld/%%ld)", + 1, name); + + gfc_trans_runtime_check (true, false, tmp, &body, + &gfc_current_locus, msg, + fold_convert (long_integer_type_node, orig_nelems), + fold_convert (long_integer_type_node, from_len)); + + free (msg); + } + tmp = build_call_vec (fcn_type, fcn, args); /* Build the body of the loop. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a499c327386..9d5e33c2114 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -6544,9 +6544,20 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) if (actual->expr->ts.type == BT_CLASS) gfc_add_class_array_ref (actual->expr); - argse.want_pointer = 1; argse.data_not_needed = 1; - gfc_conv_expr_descriptor (&argse, actual->expr); + if (gfc_is_alloc_class_array_function (actual->expr)) + { + /* For functions that return a class array conv_expr_descriptor is not + able to get the descriptor right. Therefore this special case. */ + gfc_conv_expr_reference (&argse, actual->expr); + argse.expr = gfc_build_addr_expr (NULL_TREE, + gfc_class_data_get (argse.expr)); + } + else + { + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, actual->expr); + } gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); arg1 = gfc_evaluate_now (argse.expr, &se->pre); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 67cd2b51f91..ef5153eb838 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5489,7 +5489,8 @@ gfc_trans_allocate (gfc_code * code) desc = tmp; tmp = gfc_class_data_get (tmp); } - e3_is = E3_DESC; + if (code->ext.alloc.arr_spec_from_expr3) + e3_is = E3_DESC; } else desc = !is_coarray ? se.expr diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bdf8b750469..e5c3e636c2a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2016-10-13 Andre Vehreschild + + PR fortran/72832 + * gfortran.dg/allocate_with_source_22.f03: New test. + * gfortran.dg/allocate_with_source_23.f03: New test. Expected to + fail. + 2016-10-13 Thomas Preud'homme * gcc.target/arm/movhi_movw.c: Enable test for ARM mode. diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 new file mode 100644 index 00000000000..b8689f95a54 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! Test that pr72832 is fixed now. +! Contributed by Daan van Vugt + +program allocate_source + type :: t + integer :: i + end type t + type, extends(t) :: tt + end type tt + + call test_type() + call test_class() + +contains + +subroutine test_class() + class(t), allocatable, dimension(:) :: a, b + allocate(tt::a(1:2)) + a(:)%i = [ 1,2 ] + if (size(a) /= 2) call abort() + if (any(a(:)%i /= [ 1,2])) call abort() + + allocate(b(1:4), source=a) + ! b is incorrectly initialized here. This only is diagnosed when compiled + ! with -fcheck=bounds. + if (size(b) /= 4) call abort() + if (any(b(1:2)%i /= [ 1,2])) call abort() + select type (b(1)) + class is (tt) + continue + class default + call abort() + end select +end subroutine + +subroutine test_type() + type(t), allocatable, dimension(:) :: a, b + allocate(a(1:2)) + if (size(a) /= 2) call abort() + + allocate(b(1:4), source=a) + if (size(b) /= 4) call abort() +end subroutine +end program allocate_source + + diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 new file mode 100644 index 00000000000..cfe8bd80e2f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 @@ -0,0 +1,67 @@ +! { dg-do run } +! { dg-options "-fcheck=bounds" } +! { dg-shouldfail "Array bounds mismatch" } +! +! Test that pr72832 is fixed now. +! Contributed by Daan van Vugt + +program allocate_source + type :: t + integer :: i + end type t + type, extends(t) :: tt + end type tt + + call test_type() + call test_class_correct() + call test_class_fail() + +contains + +subroutine test_class_correct() + class(t), allocatable, dimension(:) :: a, b + allocate(tt::a(1:2)) + a(:)%i = [ 1,2 ] + if (size(a) /= 2) call abort() + if (any(a(:)%i /= [ 1,2])) call abort() + + allocate(b(1:4), source=a(1)) + if (size(b) /= 4) call abort() + if (any(b(:)%i /= [ 1,1,1,1])) call abort() + select type (b(1)) + class is (tt) + continue + class default + call abort() + end select +end subroutine + +subroutine test_class_fail() + class(t), allocatable, dimension(:) :: a, b + allocate(tt::a(1:2)) + a(:)%i = [ 1,2 ] + if (size(a) /= 2) call abort() + if (any(a(:)%i /= [ 1,2])) call abort() + + allocate(b(1:4), source=a) ! Fail expected: sizes do not conform + if (size(b) /= 4) call abort() + if (any(b(1:2)%i /= [ 1,2])) call abort() + select type (b(1)) + class is (tt) + continue + class default + call abort() + end select +end subroutine + +subroutine test_type() + type(t), allocatable, dimension(:) :: a, b + allocate(a(1:2)) + if (size(a) /= 2) call abort() + + allocate(b(1:4), source=a) + if (size(b) /= 4) call abort() +end subroutine +end program allocate_source + +