[Patch, Fortran] PR fortran/37429: Missing rank on type-bound procedure call expressions

[Daniel Kraft <d at domob dot eu>]

Hi,

my type-bound procedure implementation did not save the rank on
expressions representing calls to type-bound functions (they had their
"rank" field always set to zero), which lead to the problem in PR 37429.

This patch sets the rank on resultion to that of the target procedure's
array spec.  I'm not completely sure if I've got to set the shape, too,
if possible, but the attached patch works just fine for the test cases
and gfc_match_rvalue, too, sets only the rank for ordinary functions.
So I'm quite sure the patch is complete and right as it is.  The
shape-mismatch check in the test-case works.

I'm not sure whether I should include the second test
(typebound_call_8.f03) as it is mostly a subset of the _7 test; however,
without my patch _8 ICE'd while _7 "just" missed the diagnostic (but
those two are probably thightly coupled).  What do you think?

No regressions on GNU/Linux-x86-32.  Ok to commit?  Sorry for this in
the first place :)

Cheers,
Daniel

--
Done:     Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
To go:    Hea-Kni-Mon-Pri-Ran-Rog-Tou

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.

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 140143)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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.  */
Index: gcc/testsuite/gfortran.dg/typebound_call_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_8.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_8.f03	(revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_7.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_7.f03	(revision 0)
@@ -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" } }