From: Andre Vehreschild Date: Wed, 27 May 2015 08:48:51 +0000 (+0200) Subject: trans-stmt.c (gfc_trans_allocate): Add missing location information for e3rhs. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d4cecb1341384edd198ca175e3561410afb6fe44;p=gcc.git trans-stmt.c (gfc_trans_allocate): Add missing location information for e3rhs. gcc/fortran/ChangeLog: 2015-05-27 Andre Vehreschild * trans-stmt.c (gfc_trans_allocate): Add missing location information for e3rhs. gcc/testsuite/ChangeLog: 2015-05-27 Andre Vehreschild * gfortran.dg/allocate_with_source_5.f90: Correct errorneous semantic. * gfortran.dg/allocate_with_source_6.f90: New test. From-SVN: r223738 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0bada49d283..6be535f4948 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2015-05-27 Andre Vehreschild + + PR fortran/65548 + * trans-stmt.c (gfc_trans_allocate): Add missing location + information for e3rhs. + 2015-05-26 Paul Thomas PR fortran/66082 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 2c0304b7329..81943b0142a 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5362,6 +5362,7 @@ gfc_trans_allocate (gfc_code * code) bug. */ newsym->n.sym->attr.referenced = 1; e3rhs->expr_type = EXPR_VARIABLE; + e3rhs->where = code->expr3->where; /* Set the symbols type, upto it was BT_UNKNOWN. */ newsym->n.sym->ts = e3rhs->ts; /* Check whether the expr3 is array valued. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a137eef9c04..e19504ee213 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2015-05-27 Andre Vehreschild + + PR fortran/65548 + * gfortran.dg/allocate_with_source_5.f90: Correct errorneous + semantic. + * gfortran.dg/allocate_with_source_6.f90: New test. + 2015-05-26 Eric Botcazou * gnat.dg/atomic7_1.adb: New test. diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 index 500f0f0817a..e18d6426e51 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 @@ -146,7 +146,7 @@ program test if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() o%n = 2 - allocate (o%val(2,4)) + allocate (o%val(0:1,4)) call o%make() o2%n = 3 diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 new file mode 100644 index 00000000000..7f2473aafd9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90 @@ -0,0 +1,161 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! +! Contributed by Juergen Reuter +! Check that pr65548 is fixed and that the ICE is gone, when bounds-check +! is requested. +! + +module selectors + 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 selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") call abort() + if (md5(2) /= " ") call abort() + if (md5(3) /= "fooblabar ") call abort() + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) call abort() + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort() + + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) + + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort() + + o%n = 2 + allocate (o%val(0:1,4)) + call o%make() + + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test +