From: Daniel Kraft <d@domob.eu>
Date: Tue, 9 Sep 2008 18:08:08 +0000 (+0200)
Subject: re PR fortran/37429 (Checks when assigning from a type-bound procedure broken)
X-Git-Tag: releases/gcc-4.4.0~2538
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=00ca66405c3b9da27fab36bd55e62148e97d7491;p=thirdparty%2Fgcc.git

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4cabf0293878..c8f1aaf5d92c 100644
--- a/gcc/fortran/ChangeLog
+++ b/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
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 05f2c14f4b3e..69245f2ce35f 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 311b03ea33e9..185c066b9ba9 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 000000000000..c429dc71257f
--- /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 000000000000..c8bf8d83c01d
--- /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" } }