Commit 37a40b53 by Paul Thomas

re PR fortran/40646 ([F03] array-valued procedure pointer components)

2009-07-05  Paul Thomas  <pault@gcc.gnu.org>
	and Tobias Burnus <burnus@gcc.gnu.org>

	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  <pault@gcc.gnu.org>
	and Tobias Burnus <burnus@gcc.gnu.org>

	PR fortran/40646
	* gfortran.dg/func_assign_3.f90 : New test.

From-SVN: r149262
parent aded0ed0
...@@ -1197,10 +1197,17 @@ gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) ...@@ -1197,10 +1197,17 @@ gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
bool lbound_OK = true; bool lbound_OK = true;
bool ubound_OK = true; bool ubound_OK = true;
if (contiguous)
*contiguous = false;
if (ref->type != REF_ARRAY) if (ref->type != REF_ARRAY)
return false; return false;
if (ref->u.ar.type == AR_FULL) if (ref->u.ar.type == AR_FULL)
return true; {
if (contiguous)
*contiguous = true;
return true;
}
if (ref->u.ar.type != AR_SECTION) if (ref->u.ar.type != AR_SECTION)
return false; return false;
if (ref->next) if (ref->next)
......
...@@ -1678,8 +1678,9 @@ typedef struct gfc_expr ...@@ -1678,8 +1678,9 @@ typedef struct gfc_expr
struct struct
{ {
gfc_actual_arglist* actual; gfc_actual_arglist* actual;
gfc_typebound_proc* tbp;
const char* name; const char* name;
void* padding; /* Overlap gfc_typebound_proc with esym. */
gfc_typebound_proc* tbp;
} }
compcall; compcall;
......
...@@ -4818,8 +4818,8 @@ resolve_compcall (gfc_expr* e) ...@@ -4818,8 +4818,8 @@ resolve_compcall (gfc_expr* e)
e->value.function.actual = newactual; e->value.function.actual = newactual;
e->value.function.name = e->value.compcall.name; e->value.function.name = e->value.compcall.name;
e->value.function.esym = target->n.sym;
e->value.function.isym = NULL; e->value.function.isym = NULL;
e->value.function.esym = NULL;
e->symtree = target; e->symtree = target;
e->ts = target->n.sym->ts; e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION; e->expr_type = EXPR_FUNCTION;
......
...@@ -4416,11 +4416,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) ...@@ -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 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */ functions. */
is_proc_ptr_comp(expr2, &comp);
gcc_assert (expr2->value.function.isym 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) || (!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); ss = gfc_walk_expr (expr1);
gcc_assert (ss != gfc_ss_terminator); gcc_assert (ss != gfc_ss_terminator);
......
! { dg-do run }
! Tests the fix for PR40646 in which the assignment would cause an ICE.
!
! Contributed by Charlie Sharpsteen <chuck@sharpsteen.net>
! http://gcc.gnu.org/ml/fortran/2009-07/msg00010.html
! and reported by Tobias Burnus <burnus@gcc,gnu.org>
!
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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment