[Patch, fortran, pr65894, v1] [6 Regression] severe regression in gfortran 6.0.0

[Andre Vehreschild <vehre@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 773 bytes --]

Hi all,

my work on pr60322 caused a regression on trunk. This patch fixes it. The
regression had two causes:
1. Not taking the correct attribute for BT_CLASS objects with allocatable
   components into account (chunk 1), and
2. taking the address of an address (chunk 2). When a class or derived typed
   scalar object is to be returned as a reference and a scalarizer is present,
   then the address of the address of the object was returned. The former code
   was meant to return the address of an array element for which taking the
   address was ok. The patch now prevents taking the additional address when
   the object is scalar.

Bootstraps and regtests ok x86_64-linux-gnu/f21.

Ok for trunk.

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

[-- Attachment #2: pr65894_1.clog --]
[-- Type: application/octet-stream, Size: 457 bytes --]

gcc/testsuite/ChangeLog:

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

	PR fortran/65894
	* gfortran.dg/elemental_subroutine_11.f90: New test.


gcc/fortran/ChangeLog:

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

	PR fortran/65894
	* trans-expr.c (gfc_conv_procedure_call): Extend test for
	allocatable components of class objects.
	(gfc_conv_expr_reference): Prevent taking the address of a
	pointer when the object is a scalar class or type entity.


[-- Attachment #3: pr65894_1.patch --]
[-- Type: text/x-patch, Size: 9318 bytes --]

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 16e584a..19d0144 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4741,13 +4741,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	     copied.  */
 	  if (fsym && (fsym->attr.value
 		       || (e->expr_type == EXPR_VARIABLE
-			   && fsym->ts.type == BT_DERIVED
-			   && e->ts.type == BT_DERIVED
-			   && !e->ts.u.derived->attr.dimension
 			   && !e->rank
-			   && (!e->symtree
-			       || (!e->symtree->n.sym->attr.allocatable
-				   && !e->symtree->n.sym->attr.pointer)))))
+			   && ((fsym->ts.type == BT_DERIVED
+				&& e->ts.type == BT_DERIVED
+				&& !e->ts.u.derived->attr.dimension
+				&& (!e->symtree
+				    || (!e->symtree->n.sym->attr.allocatable
+					&& !e->symtree->n.sym->attr.pointer)))
+			       || (fsym->ts.type == BT_CLASS
+				   && e->ts.type == BT_CLASS
+				   && !CLASS_DATA (e)->attr.dimension)))))
 	    gfc_conv_expr (&parmse, e);
 	  else
 	    gfc_conv_expr_reference (&parmse, e);
@@ -7461,7 +7464,13 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
       if (expr->ts.type == BT_CHARACTER
 	  && expr->expr_type != EXPR_FUNCTION)
 	gfc_conv_string_parameter (se);
-      else
+      /* Do not return the address of the expression, when it is already an
+	 address.  */
+      else if (!(((expr->ts.type == BT_DERIVED
+		  && expr->ts.u.derived->as == NULL)
+		 || (expr->ts.type == BT_CLASS
+		     && CLASS_DATA (expr)->as == NULL))
+		 && POINTER_TYPE_P (TREE_TYPE (se->expr))))
 	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 
       return;
diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90
new file mode 100644
index 0000000..6b13e46
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90
@@ -0,0 +1,250 @@
+! { dg-do run }
+!
+! Check error of pr65894 are fixed.
+! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
+!                Andre Vehreschild  <vehre@gcc.gnu.org>
+
+module simple_string
+  ! Minimal iso_varying_string implementation needed.
+  implicit none
+
+  type string_t
+    private
+    character(len=1), dimension(:), allocatable :: cs
+  end type string_t
+
+contains
+  elemental function var_str(c) result (s)
+    character(*), intent(in) :: c
+    type(string_t) :: s
+    integer :: l,i
+
+    l = len(c)
+    allocate(s%cs(l))
+    forall(i = 1:l)
+      s%cs(i) = c(i:i)
+    end forall
+  end function var_str
+
+end module simple_string
+module model_data
+  use simple_string
+
+  implicit none
+  private
+
+  public :: field_data_t
+  public :: model_data_t
+
+  type :: field_data_t
+     !private
+     integer :: pdg = 0
+     type(string_t), dimension(:), allocatable :: name
+   contains
+     procedure :: init => field_data_init
+     procedure :: get_pdg => field_data_get_pdg
+  end type field_data_t
+
+  type :: model_data_t
+     !private
+     type(string_t) :: name
+     type(field_data_t), dimension(:), allocatable :: field
+   contains
+     generic :: init => model_data_init
+     procedure, private :: model_data_init
+     generic :: get_pdg => &
+          model_data_get_field_pdg_index
+     procedure, private :: model_data_get_field_pdg_index
+     generic :: get_field_ptr => &
+          model_data_get_field_ptr_pdg
+     procedure, private :: model_data_get_field_ptr_pdg
+     procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index
+     procedure :: init_sm_test => model_data_init_sm_test
+  end type model_data_t
+
+contains
+
+  subroutine field_data_init (prt, pdg)
+    class(field_data_t), intent(out) :: prt
+    integer, intent(in) :: pdg
+    prt%pdg = pdg
+  end subroutine field_data_init
+
+  elemental function field_data_get_pdg (prt) result (pdg)
+    integer :: pdg
+    class(field_data_t), intent(in) :: prt
+    pdg = prt%pdg
+  end function field_data_get_pdg
+
+  subroutine model_data_init (model, name, &
+       n_field)
+    class(model_data_t), intent(out) :: model
+    type(string_t), intent(in) :: name
+    integer, intent(in) :: n_field
+    model%name = name
+    allocate (model%field (n_field))
+  end subroutine model_data_init
+
+  function model_data_get_field_pdg_index (model, i) result (pdg)
+    class(model_data_t), intent(in) :: model
+    integer, intent(in) :: i
+    integer :: pdg
+    pdg = model%field(i)%get_pdg ()
+  end function model_data_get_field_pdg_index
+
+  function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr)
+    class(model_data_t), intent(in), target :: model
+    integer, intent(in) :: pdg
+    logical, intent(in), optional :: check
+    type(field_data_t), pointer :: ptr
+    integer :: i, pdg_abs
+    if (pdg == 0) then
+       ptr => null ()
+       return
+    end if
+    pdg_abs = abs (pdg)
+    if (lbound(model%field, 1) /= 1) call abort()
+    if (ubound(model%field, 1) /= 19) call abort()
+    do i = 1, size (model%field)
+       if (model%field(i)%get_pdg () == pdg_abs) then
+          ptr => model%field(i)
+          return
+       end if
+    end do
+    ptr => null ()
+  end function model_data_get_field_ptr_pdg
+
+  function model_data_get_field_ptr_index (model, i) result (ptr)
+    class(model_data_t), intent(in), target :: model
+    integer, intent(in) :: i
+    type(field_data_t), pointer :: ptr
+    if (lbound(model%field, 1) /= 1) call abort()
+    if (ubound(model%field, 1) /= 19) call abort()
+    ptr => model%field(i)
+  end function model_data_get_field_ptr_index
+
+  subroutine model_data_init_sm_test (model)
+    class(model_data_t), intent(out) :: model
+    type(field_data_t), pointer :: field
+    integer, parameter :: n_field = 19
+    call model%init (var_str ("SM_test"), &
+         n_field)
+    field => model%get_field_ptr_by_index (1)
+    call field%init (1)
+  end subroutine model_data_init_sm_test
+
+end module model_data
+
+module flavors
+  use model_data
+
+  implicit none
+  private
+
+  public :: flavor_t
+
+  type :: flavor_t
+     private
+     integer :: f = 0
+     type(field_data_t), pointer :: field_data => null ()
+   contains
+     generic :: init => &
+          flavor_init0_model
+     procedure, private :: flavor_init0_model
+  end type flavor_t
+
+contains
+
+  impure elemental subroutine flavor_init0_model (flv, f, model)
+    class(flavor_t), intent(inout) :: flv
+    integer, intent(in) :: f
+    class(model_data_t), intent(in), target :: model
+    ! Check the field l/ubound at various stages, because w/o the patch
+    ! the bounds get mixed up.
+    if (lbound(model%field, 1) /= 1) call abort()
+    if (ubound(model%field, 1) /= 19) call abort()
+    flv%f = f
+    flv%field_data => model%get_field_ptr (f, check=.true.)
+  end subroutine flavor_init0_model
+end module flavors
+
+module beams
+  use model_data
+  use flavors
+  implicit none
+  private
+  public :: beam_1
+  public :: beam_2
+contains
+  subroutine beam_1 (u)
+    integer, intent(in) :: u
+    type(flavor_t), dimension(2) :: flv
+    real, dimension(2) :: pol_f
+    type(model_data_t), target :: model
+    call model%init_sm_test ()
+    call flv%init ([1,-1], model)
+    pol_f(1) = 0.5
+  end subroutine beam_1
+  subroutine beam_2 (u, model)
+    integer, intent(in) :: u
+    type(flavor_t), dimension(2) :: flv
+    real, dimension(2) :: pol_f
+    class(model_data_t), intent(in), target :: model
+    call flv%init ([1,-1], model)
+    pol_f(1) = 0.5
+  end subroutine beam_2
+end module beams
+
+module evaluators
+  ! This module is just here for a compile check.
+  implicit none
+  private
+  type :: quantum_numbers_mask_t
+   contains
+     generic :: operator(.or.) => quantum_numbers_mask_or
+     procedure, private :: quantum_numbers_mask_or
+  end type quantum_numbers_mask_t
+
+  type :: index_map_t
+     integer, dimension(:), allocatable :: entry
+  end type index_map_t
+  type :: prt_mask_t
+     logical, dimension(:), allocatable :: entry
+  end type prt_mask_t
+  type :: qn_mask_array_t
+     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
+  end type qn_mask_array_t
+
+contains
+  elemental function quantum_numbers_mask_or (mask1, mask2) result (mask)
+    type(quantum_numbers_mask_t) :: mask
+    class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
+  end function quantum_numbers_mask_or
+
+  subroutine make_product_interaction &
+      (prt_is_connected, qn_mask_in, qn_mask_rest)
+    type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
+    type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in
+    type(quantum_numbers_mask_t), intent(in) :: qn_mask_rest
+    type(index_map_t), dimension(2) :: prt_index_in
+    integer :: i
+    type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
+    allocate (qn_mask (2))
+    do i = 1, 2
+       qn_mask(prt_index_in(i)%entry) = &
+            pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) &
+            .or. qn_mask_rest
+      ! Without the patch above line produced an ICE.
+    end do
+  end subroutine make_product_interaction
+end module evaluators
+program main
+  use beams
+  use model_data
+  type(model_data_t) :: model
+  call model%init_sm_test()
+  call beam_1 (6)
+  call beam_2 (6, model)
+end program main
+
+! vim:ts=2:sts=2:sw=2:cindent: