re PR fortran/37429 (Checks when assigning from a type-bound procedure broken)

2008-09-09  Daniel Kraft  <d@domob.eu>

	PR fortran/37429
	* resolve.c (expression_rank): Added assertion to guard against
	EXPR_COMPCALL expressions.
	(resolve_compcall): Set expression's rank from the target procedure's.

2008-09-09  Daniel Kraft  <d@domob.eu>

	PR fortran/37429
	* gfortran.dg/typebound_call_7.f03: New test.
	* gfortran.dg/typebound_call_8.f03: New test.

From-SVN: r140163

5 files changed, 104 insertions, 0 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4cabf02..c8f1aaf 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,12 @@
 2008-09-09  Daniel Kraft  <d@domob.eu>
 
+	PR fortran/37429
+	* resolve.c (expression_rank): Added assertion to guard against
+	EXPR_COMPCALL expressions.
+	(resolve_compcall): Set expression's rank from the target procedure's.
+
+2008-09-09  Daniel Kraft  <d@domob.eu>
+
 	PR fortran/37411
 	* trans-array.c (gfc_conv_array_parameter): Added assertion that the
 	symbol has an array spec.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 05f2c14..69245f2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4021,6 +4021,10 @@ expression_rank (gfc_expr *e)
   gfc_ref *ref;
   int i, rank;
 
+  /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
+     could lead to serious confusion...  */
+  gcc_assert (e->expr_type != EXPR_COMPCALL);
+
   if (e->ref == NULL)
     {
       if (e->expr_type == EXPR_ARRAY)
@@ -4550,6 +4554,11 @@ resolve_compcall (gfc_expr* e)
 
   if (resolve_typebound_generic_call (e) == FAILURE)
     return FAILURE;
+  gcc_assert (!e->value.compcall.tbp->is_generic);
+
+  /* Take the rank from the function's symbol.  */
+  if (e->value.compcall.tbp->u.specific->n.sym->as)
+    e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
 
   /* For now, we simply transform it into an EXPR_FUNCTION call with the same
      arglist to the TBP's binding target.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 311b03e..185c066 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2008-09-09  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37429
+	* gfortran.dg/typebound_call_7.f03: New test.
+	* gfortran.dg/typebound_call_8.f03: New test.
+
 2008-09-09  Richard Guenther  <rguenther@suse.de>
 
 	PR middle-end/37354
diff --git a/gcc/testsuite/gfortran.dg/typebound_call_7.f03 b/gcc/testsuite/gfortran.dg/typebound_call_7.f03
new file mode 100644
index 0000000..c429dc7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_call_7.f03
@@ -0,0 +1,50 @@
+! { dg-do compile}
+
+! PR fortran/37429
+! Checks for assignments from type-bound functions.
+
+MODULE touching
+  IMPLICIT NONE
+
+  TYPE :: EqnSys33
+  CONTAINS
+    PROCEDURE, NOPASS :: solve1
+    PROCEDURE, NOPASS :: solve2
+    PROCEDURE, NOPASS :: solve3
+  END TYPE EqnSys33
+
+CONTAINS
+
+  FUNCTION solve1 ()
+    IMPLICIT NONE
+    REAL :: solve1(3)
+    solve1 = 0.0
+  END FUNCTION solve1
+
+  CHARACTER(len=5) FUNCTION solve2 ()
+    IMPLICIT NONE
+    solve2 = "hello"
+  END FUNCTION solve2
+
+  REAL FUNCTION solve3 ()
+    IMPLICIT NONE
+    solve3 = 4.2
+  END FUNCTION solve3
+
+  SUBROUTINE fill_gap ()
+    IMPLICIT NONE
+    TYPE(EqnSys33) :: sys
+    REAL :: res
+    REAL :: resArr(3), resSmall(2)
+
+    res = sys%solve1 () ! { dg-error "Incompatible rank" }
+    res = sys%solve2 () ! { dg-error "Can't convert" }
+    resSmall = sys%solve1 () ! { dg-error "Different shape" }
+
+    res = sys%solve3 ()
+    resArr = sys%solve1 ()
+  END SUBROUTINE fill_gap
+
+END MODULE touching
+
+! { dg-final { cleanup-modules "touching" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_call_8.f03 b/gcc/testsuite/gfortran.dg/typebound_call_8.f03
new file mode 100644
index 0000000..c8bf8d8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_call_8.f03
@@ -0,0 +1,32 @@
+! { dg-do compile}
+
+! PR fortran/37429
+! This used to ICE, check that is fixed.
+
+MODULE touching
+  IMPLICIT NONE
+
+  TYPE :: EqnSys33
+  CONTAINS
+    PROCEDURE, NOPASS :: solve1
+  END TYPE EqnSys33
+
+CONTAINS
+
+  FUNCTION solve1 ()
+    IMPLICIT NONE
+    REAL :: solve1(3)
+    solve1 = 0.0
+  END FUNCTION solve1
+
+  SUBROUTINE fill_gap ()
+    IMPLICIT NONE
+    TYPE(EqnSys33) :: sys
+    REAL :: res
+
+    res = sys%solve1 () ! { dg-error "Incompatible rank" }
+  END SUBROUTINE fill_gap
+
+END MODULE touching
+
+! { dg-final { cleanup-modules "touching" } }