Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 241086) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -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. Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 241086) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -1235,6 +1235,7 @@ 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 @@ } 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. */ Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 241086) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -6544,9 +6544,20 @@ 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); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 241086) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -5489,7 +5489,8 @@ 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 Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 241086) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -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. Index: gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 (nicht existent) +++ gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 (Arbeitskopie) @@ -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 + + Index: gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 (nicht existent) +++ gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 (Arbeitskopie) @@ -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 + +