From: Paul Thomas <pault@gcc.gnu.org>
Date: Sun, 23 Apr 2006 11:56:37 +0000 (+0000)
Subject: re PR fortran/25099 (Conformance of arguments to ELEMENTAL subroutines)
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=c9379bf062307760ddf408620d5e233700583c78;p=platform%2Fupstream%2Fgcc.git

re PR fortran/25099 (Conformance of arguments to ELEMENTAL subroutines)

2006-04-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25099
	* resolve.c (resolve_call): Check conformity of elemental
	subroutine actual arguments.

2006-04-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25099
	* gfortran.dg/elemental_subroutine_4.f90: New test.
	* gfortran.dg/assumed_size_refs_1.f90: Add error to non-conforming
	call sub (m, x).

From-SVN: r113194
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d10a53e..b64b6c7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2006-04-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25099
+	* resolve.c (resolve_call): Check conformity of elemental
+	subroutine actual arguments.
+
 2006-04-22  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/26769
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fce2322..1e57add 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1657,18 +1657,33 @@ resolve_call (gfc_code * c)
 	gfc_internal_error ("resolve_subroutine(): bad function type");
       }
 
+  /* Some checks of elemental subroutines.  */
   if (c->ext.actual != NULL
       && c->symtree->n.sym->attr.elemental)
     {
       gfc_actual_arglist * a;
-      /* Being elemental, the last upper bound of an assumed size array
-	 argument must be present.  */
+      gfc_expr * e;
+      e = NULL;
+
       for (a = c->ext.actual; a; a = a->next)
 	{
-	  if (a->expr != NULL
-		&& a->expr->rank > 0
-		&& resolve_assumed_size_actual (a->expr))
+	  if (a->expr == NULL || a->expr->rank == 0)
+	    continue;
+
+	 /* The last upper bound of an assumed size array argument must
+	    be present.  */
+	  if (resolve_assumed_size_actual (a->expr))
 	    return FAILURE;
+
+	  /* Array actual arguments must conform.  */
+	  if (e != NULL)
+	    {
+	      if (gfc_check_conformance ("elemental subroutine", a->expr, e)
+			== FAILURE)
+		return FAILURE;
+	    }
+	  else
+	    e = a->expr;
 	}
     }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3264503..7a3fb00 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2006-04-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25099
+	* gfortran.dg/elemental_subroutine_4.f90: New test.
+	* gfortran.dg/assumed_size_refs_1.f90: Add error to non-conforming
+	call sub (m, x).
+
 2006-04-22  Joseph S. Myers  <joseph@codesourcery.com>
 
 	* gcc.c-torture/compile/20060421-1.c: New testcase.
diff --git a/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
index ff42c02..1590ec5 100644
--- a/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
@@ -35,7 +35,7 @@ contains
     x = fcn (m)                ! { dg-error "upper bound in the last dimension" }
     m(:, 1:2) = fcn (q)
     call sub (m, x)            ! { dg-error "upper bound in the last dimension" }
-    call sub (m(1:2, 1:2), x)
+    call sub (m(1:2, 1:2), x)  ! { dg-error "Incompatible ranks in elemental subroutine" }
     print *, p
 
     call DHSEQR(x)
diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90
new file mode 100644
index 0000000..1a34462
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! Test the fix for PR25099, in which conformance checking was not being
+! done for elemental subroutines and therefore for interface assignments.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+module elem_assign
+   implicit none
+   type mytype
+      integer x
+   end type mytype
+   interface assignment(=)
+      module procedure myassign
+   end interface assignment(=)
+   contains
+      elemental subroutine myassign(x,y)
+         type(mytype), intent(out) :: x
+         type(mytype), intent(in) :: y
+         x%x = y%x
+      end subroutine myassign
+end module elem_assign
+
+   use elem_assign
+   integer :: I(2,2),J(2)
+   type (mytype) :: w(2,2), x(4), y(5), z(4)
+! The original PR
+   CALL S(I,J) ! { dg-error "Incompatible ranks in elemental subroutine" }
+! Check interface assignments
+   x = w       ! { dg-error "Incompatible ranks in elemental subroutine" }
+   x = y       ! { dg-error "different shape for elemental subroutine" }
+   x = z
+CONTAINS
+   ELEMENTAL SUBROUTINE S(I,J)
+     INTEGER, INTENT(IN) :: I,J
+   END SUBROUTINE S
+END
+
+! { dg-final { cleanup-modules "elem_assign" } }