From 37a40b531fa727259d2990fe37795a1ada14b831 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 5 Jul 2009 19:13:59 +0000 Subject: [PATCH] re PR fortran/40646 ([F03] array-valued procedure pointer components) 2009-07-05 Paul Thomas and Tobias Burnus PR fortran/40646 * gfortran.h : Change the compcall member of the 'value' union in the gfc_expr structure so that its fields overlap with the 'function' member. * resolve.c (resolve_compcall): Set the function.esym. * trans-expr.c (gfc_trans_arrayfunc_assign): Use is_proc_ptr_comp in the condition. * dependency.c (gfc_full_array_ref_p): Ensure that 'contiguous' retunrs a value if non-NULL. 2009-07-05 Paul Thomas and Tobias Burnus PR fortran/40646 * gfortran.dg/func_assign_3.f90 : New test. From-SVN: r149262 --- gcc/fortran/dependency.c | 9 +++++++- gcc/fortran/gfortran.h | 3 ++- gcc/fortran/resolve.c | 2 +- gcc/fortran/trans-expr.c | 6 +++--- gcc/testsuite/gfortran.dg/func_assign_3.f90 | 32 +++++++++++++++++++++++++++++ 5 files changed, 46 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/func_assign_3.f90 diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index eb07e7c..f597e6e 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -1197,10 +1197,17 @@ gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) bool lbound_OK = true; bool ubound_OK = true; + if (contiguous) + *contiguous = false; + if (ref->type != REF_ARRAY) return false; if (ref->u.ar.type == AR_FULL) - return true; + { + if (contiguous) + *contiguous = true; + return true; + } if (ref->u.ar.type != AR_SECTION) return false; if (ref->next) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6712741..260d718 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1678,8 +1678,9 @@ typedef struct gfc_expr struct { gfc_actual_arglist* actual; - gfc_typebound_proc* tbp; const char* name; + void* padding; /* Overlap gfc_typebound_proc with esym. */ + gfc_typebound_proc* tbp; } compcall; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index c106948..41ac037 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4818,8 +4818,8 @@ resolve_compcall (gfc_expr* e) e->value.function.actual = newactual; e->value.function.name = e->value.compcall.name; + e->value.function.esym = target->n.sym; e->value.function.isym = NULL; - e->value.function.esym = NULL; e->symtree = target; e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e872f22..d4ee169 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4416,11 +4416,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic functions. */ - is_proc_ptr_comp(expr2, &comp); gcc_assert (expr2->value.function.isym - || (comp && comp->attr.dimension) + || (is_proc_ptr_comp (expr2, &comp) + && comp && comp->attr.dimension) || (!comp && gfc_return_by_reference (expr2->value.function.esym) - && expr2->value.function.esym->result->attr.dimension)); + && expr2->value.function.esym->result->attr.dimension)); ss = gfc_walk_expr (expr1); gcc_assert (ss != gfc_ss_terminator); diff --git a/gcc/testsuite/gfortran.dg/func_assign_3.f90 b/gcc/testsuite/gfortran.dg/func_assign_3.f90 new file mode 100644 index 0000000..174cbc5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/func_assign_3.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! Tests the fix for PR40646 in which the assignment would cause an ICE. +! +! Contributed by Charlie Sharpsteen +! http://gcc.gnu.org/ml/fortran/2009-07/msg00010.html +! and reported by Tobias Burnus +! +module bugTestMod + implicit none + type:: boundTest + contains + procedure, nopass:: test => returnMat + end type boundTest +contains + function returnMat( a, b ) result( mat ) + integer:: a, b, i + double precision, dimension(a,b):: mat + mat = dble (reshape ([(i, i = 1, a * b)],[a,b])) + return + end function returnMat +end module bugTestMod + +program bugTest + use bugTestMod + implicit none + integer i + double precision, dimension(2,2):: testCatch + type( boundTest ):: testObj + testCatch = testObj%test(2,2) ! This would cause an ICE + if (any (testCatch .ne. dble (reshape ([(i, i = 1, 4)],[2,2])))) call abort +end program bugTest +! { dg-final { cleanup-modules "bugTestMod" } } -- 2.7.4