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

gcc/fortran/ChangeLog

@@ -1,3 +1,10 @@
+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

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.  */

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

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" } }

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" } }