From: Andre Vehreschild Date: Tue, 7 Apr 2015 14:10:43 +0000 (+0200) Subject: re PR fortran/65548 (gfc_conv_procedure_call) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=440f9408ea950a29ef7606b6114d84d1a5b53c90;p=gcc.git re PR fortran/65548 (gfc_conv_procedure_call) PR fortran/65548 * gfortran.dg/allocate_with_source_5.f90: New test. * trans-stmt.c (gfc_trans_allocate): For intrinsic functions use conv_expr_descriptor() instead of conv_expr_reference(). From-SVN: r221897 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7bba9d402d6..f7b1d38d654 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2015-04-07 Andre Vehreschild + + PR fortran/65548 + * trans-stmt.c (gfc_trans_allocate): For intrinsic functions + use conv_expr_descriptor() instead of conv_expr_reference(). + 2015-03-30 Jakub Jelinek PR fortran/65597 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index a6fb52c51e1..619564b6ef9 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5049,12 +5049,17 @@ gfc_trans_allocate (gfc_code * code) /* In all other cases evaluate the expr3 and create a temporary. */ gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->rank != 0 + && code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->value.function.isym) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); if (code->expr3->ts.type == BT_CLASS) gfc_conv_class_to_class (&se, code->expr3, code->expr3->ts, false, true, - false,false); + false, false); gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); /* Prevent aliasing, i.e., se.expr may be already a diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a51b9c56abb..34d12535e02 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-04-07 Andre Vehreschild + + PR fortran/65548 + * gfortran.dg/allocate_with_source_5.f90: New test. + 2015-04-07 Ilya Enkovich * gcc.target/i386/mpx/chkp-thunk-comdat-1.cc: New. diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 new file mode 100644 index 00000000000..e934e0873b3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Check that pr65548 is fixed. +! Contributed by Juergen Reuter + +module allocate_with_source_5_module + + type :: selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t + +contains + + subroutine selector_init (selector, weight) + class(selector_t), intent(out) :: selector + real, dimension(:), intent(in) :: weight + real :: s + integer :: n, i + logical, dimension(:), allocatable :: mask + s = sum (weight) + allocate (mask (size (weight)), source = weight /= 0) + n = count (mask) + if (n > 0) then + allocate (selector%map (n), & + source = pack ([(i, i = 1, size (weight))], mask)) + allocate (selector%weight (n), & + source = pack (weight / s, mask)) + else + allocate (selector%map (1), source = 1) + allocate (selector%weight (1), source = 0.) + end if + end subroutine selector_init + +end module allocate_with_source_5_module + +program allocate_with_source_5 + use allocate_with_source_5_module + + class(selector_t), allocatable :: sel; + real, dimension(5) :: w = [ 1, 0, 2, 0, 3]; + + allocate (sel) + call sel%init(w) + + if (any(sel%map /= [ 1, 3, 5])) call abort() + if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort() +end program allocate_with_source_5 +! { dg-final { cleanup-modules "allocate_with_source_5_module" } } +