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

diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index eb07e7c..f597e6e 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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  <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" } }