@@ -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;
new file mode 100644
@@ -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: