Hi All!
Proposed patch to:
PR100120 - associated intrinsic failure
Patch tested only on x86_64-pc-linux-gnu.
Add code to ensure that pointers have the correct dynamic type.
The patch depends on PR100097 and PR100098.
Thank you very much.
Best regards,
José Rui
Fortran: Fix associated intrinsic failure [PR100120]
gcc/fortran/ChangeLog:
PR fortran/100120
* trans-array.c (gfc_conv_expr_descriptor): add code to ensure
that pointers have the correct dynamic type.
gcc/testsuite/ChangeLog:
PR fortran/100120
* gfortran.dg/PR100120.f90: New test.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ca90142530c..0ef6c788465 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7598,6 +7598,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
int dim, ndim, codim;
tree parm;
tree parmtype;
+ tree dtype;
tree stride;
tree from;
tree to;
@@ -7670,24 +7671,24 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
loop.from[dim] = gfc_index_one_node;
}
+ /* The destination must carry the dynamic type of the expression... */
desc = info->descriptor;
+ if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
+ parmtype = gfc_typenode_for_spec (&expr->ts);
+ else
+ parmtype = gfc_get_element_type (TREE_TYPE (desc));
+
+ /* ...But the destination has it's own rank and shape. */
+ parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
+ loop.from, loop.to, 0,
+ GFC_ARRAY_UNKNOWN, false);
+
if (se->direct_byref && !se->byref_noassign)
- {
- /* For pointer assignments we fill in the destination. */
- parm = se->expr;
- parmtype = TREE_TYPE (parm);
- }
+ /* For pointer assignments we fill in the destination. */
+ parm = se->expr;
else
{
/* Otherwise make a new one. */
- if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
- parmtype = gfc_typenode_for_spec (&expr->ts);
- else
- parmtype = gfc_get_element_type (TREE_TYPE (desc));
-
- parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
- loop.from, loop.to, 0,
- GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
/* When expression is a class object, then add the class' handle to
@@ -7731,8 +7732,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
the offsets because all elements are within the array data. */
/* Set the dtype. */
+ if (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree->n.sym->attr.dummy
+ && IS_CLASS_ARRAY (expr->symtree->n.sym))
+ {
+ tmp = gfc_get_class_from_gfc_expr (expr);
+ tmp = gfc_class_data_get (tmp);
+ dtype = gfc_conv_descriptor_dtype (tmp);
+ }
+ else
+ dtype = gfc_get_dtype (parmtype);
tmp = gfc_conv_descriptor_dtype (parm);
- gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
+ gfc_add_modify (&loop.pre, tmp, dtype);
/* The 1st element in the section. */
base = gfc_index_zero_node;
diff --git a/gcc/testsuite/gfortran.dg/PR100120.f90 b/gcc/testsuite/gfortran.dg/PR100120.f90
new file mode 100644
index 00000000000..58a22d72c26
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100120.f90
@@ -0,0 +1,166 @@
+! { dg-do run }
+!
+! Tests fix for PR100120
+!
+
+program main_p
+
+ implicit none
+
+ integer, parameter :: n = 11
+
+ type :: foo_t
+ integer :: i
+ end type foo_t
+
+ type, extends(foo_t) :: bar_t
+ integer :: j(n)
+ end type bar_t
+
+ class(*), pointer :: spu
+ class(*), pointer :: apu(:)
+ class(foo_t), pointer :: spf
+ class(foo_t), pointer :: apf(:)
+ class(bar_t), pointer :: spb
+ class(bar_t), pointer :: apb(:)
+ type(foo_t), target :: afd(n)
+ type(bar_t), target :: abd(n)
+ integer, target :: ain(n)
+ integer :: i
+
+ ain = [(i, i=1,n)]
+ afd%i = ain
+ abd%i = ain
+ do i = 1, n
+ abd(i)%j = ain
+ end do
+
+ apu => ain
+ if(.not.associated(apu)) stop 1
+ if(.not.associated(apu, ain)) stop 2
+ select type(apu)
+ type is(integer)
+ if(any(apu/=ain)) stop 3
+ class default
+ stop 4
+ end select
+ spu => ain(n)
+ if(.not.associated(spu)) stop 5
+ if(.not.associated(spu, ain(n))) stop 6
+ select type(spu)
+ type is(integer)
+ if(spu/=n) stop 7
+ class default
+ stop 8
+ end select
+
+ apu => afd
+ if(.not.associated(apu)) stop 10
+ if(.not.associated(apu, afd)) stop 11
+ select type(apu)
+ type is(foo_t)
+ if(any(apu%i/=afd%i)) stop 12
+ class default
+ stop 13
+ end select
+ spu => afd(n)
+ if(.not.associated(spu)) stop 14
+ if(.not.associated(spu, afd(n))) stop 15
+ select type(spu)
+ type is(foo_t)
+ if(spu%i/=n) stop 16
+ class default
+ stop 17
+ end select
+
+ apu => abd
+ if(.not.associated(apu)) stop 20
+ if(.not.associated(apu, abd)) stop 21
+ select type(apu)
+ type is(bar_t)
+ if(any(apu%i/=abd%i)) stop 22
+ do i = 1, n
+ if(any(apu(i)%j/=ain)) stop 23
+ end do
+ class default
+ stop 24
+ end select
+ spu => abd(n)
+ if(.not.associated(spu)) stop 25
+ if(.not.associated(spu, abd(n))) stop 26
+ select type(spu)
+ type is(bar_t)
+ if(spu%i/=n) stop 27
+ if(any(spu%j/=ain)) stop 28
+ class default
+ stop 29
+ end select
+
+ apf => afd
+ if(.not.associated(apf)) stop 30
+ if(.not.associated(apf, afd)) stop 31
+ select type(apf)
+ type is(foo_t)
+ if(any(apf%i/=afd%i)) stop 32
+ class default
+ stop 33
+ end select
+ spf => afd(n)
+ if(.not.associated(spf)) stop 34
+ if(.not.associated(spf, afd(n))) stop 35
+ select type(spf)
+ type is(foo_t)
+ if(spf%i/=n) stop 36
+ class default
+ stop 37
+ end select
+
+ apf => abd
+ if(.not.associated(apf)) stop 40
+ if(.not.associated(apf, abd)) stop 41
+ select type(apf)
+ type is(bar_t)
+ if(any(apf%i/=abd%i)) stop 42
+ do i = 1, n
+ if(any(apf(i)%j/=ain)) stop 43
+ end do
+ class default
+ stop 44
+ end select
+ spf => abd(n)
+ if(.not.associated(spf)) stop 45
+ if(.not.associated(spf, abd(n))) stop 46
+ select type(spf)
+ type is(bar_t)
+ if(spf%i/=n) stop 47
+ if(any(spf%j/=ain)) stop 48
+ class default
+ stop 49
+ end select
+
+ apb => abd
+ if(.not.associated(apb)) stop 50
+ if(.not.associated(apb, abd)) stop 51
+ select type(apb)
+ type is(bar_t)
+ if(any(apb%i/=abd%i)) stop 52
+ do i = 1, n
+ if(any(apb(i)%j/=ain)) stop 53
+ end do
+ class default
+ stop 54
+ end select
+ spb => abd(n)
+ if(.not.associated(spb)) stop 55
+ if(.not.associated(spb, abd(n))) stop 56
+ select type(spb)
+ type is(bar_t)
+ if(spb%i/=n) stop 57
+ if(any(spb%j/=ain)) stop 58
+ class default
+ stop 59
+ end select
+
+ stop
+
+end program main_p
