trans-stmt.c (gfc_trans_allocate): Add missing location information for e3rhs.

gcc/fortran/ChangeLog:

2015-05-27  Andre Vehreschild  <vehre@gmx.de>

	* trans-stmt.c (gfc_trans_allocate): Add missing location
	information for e3rhs.

gcc/testsuite/ChangeLog:

2015-05-27  Andre Vehreschild  <vehre@gmx.de>

	* 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 0bada49d283191a2fb82231f7e3b97a68e00c1ba..6be535f49482406769331339382cd903604de9cf 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2015-05-27  Andre Vehreschild  <vehre@gmx.de>
+
+       PR fortran/65548
+       * trans-stmt.c (gfc_trans_allocate): Add missing location
+       information for e3rhs.
+
 2015-05-26  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/66082

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 2c0304b7329d3b894dfdaac33d399ba8b5f91810..81943b0142acdf63a64c040365605f58bc6b3fcd 100644 (file)
--- 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 a137eef9c0470ea3b2bced15263062d434b36bf1..e19504ee21371d98d07dd5e50559ba629914976d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2015-05-27  Andre Vehreschild  <vehre@gmx.de>
+
+       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  <ebotcazou@adacore.com>
 
        * 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 500f0f0817a825fac56ac4dfbc49bc10c1204c99..e18d6426e517cd5480b1f160636bdf0bf3402aba 100644 (file)
--- 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 (file)
index 0000000..7f2473a
--- /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
+